diff options
Diffstat (limited to 'lisp/emacs-lisp')
85 files changed, 2684 insertions, 1332 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4ee830023fc..c0da59c81cb 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ ;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993-1994, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2000-2016 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org @@ -1629,7 +1629,7 @@ COMPILE argument of `ad-activate' was supplied as nil." Only proper subtrees are considered, for example, if TREE is (1 (2 (3)) 4) then the subtrees will be 1 (2 (3)) 2 (3) 3 4, dotted structures are allowed too. Once a qualifying subtree has been found its subtrees will -not be considered anymore. (ad-substitute-tree 'atom 'identity tree) +not be considered anymore. (ad-substitute-tree \\='atom \\='identity tree) generates a copy of TREE." (cond ((consp tReE) (cons (if (funcall sUbTrEe-TeSt (car tReE)) @@ -1832,7 +1832,7 @@ Redefining advices affect the construction of an advised definition." ;; @@ Interactive input functions: ;; =============================== -(declare-function 'function-called-at-point "help") +(declare-function function-called-at-point "help") (defun ad-read-advised-function (&optional prompt predicate default) "Read name of advised function with completion from the minibuffer. @@ -2419,7 +2419,7 @@ as if they had been supplied to a function with TARGET-ARGLIST directly. Excess source arguments will be neglected, missing source arguments will be supplied as nil. Returns a `funcall' or `apply' form with the second element being `function' which has to be replaced by an actual function argument. -Example: (ad-map-arglists '(a &rest args) '(w x y z)) will return +Example: (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))." (let* ((parsed-source-arglist (ad-parse-arglist source-arglist)) (source-reqopt-args (append (nth 0 parsed-source-arglist) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 12d0a94127f..1292ea992d3 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,6 +1,6 @@ ;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- -;; Copyright (C) 1991-1997, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1991-1997, 2001-2016 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint @@ -87,6 +87,29 @@ that text will be copied verbatim to `generated-autoload-file'.") (defconst generate-autoload-section-continuation ";;;;;; " "String to add on each continuation of the section header form.") +;; In some ways it would be nicer to use a value that is recognizably +;; not a time-value, eg t, but that can cause issues if an older Emacs +;; that does not expect non-time-values loads the file. +(defconst autoload--non-timestamp '(0 0 0 0) + "Value to insert when `autoload-timestamps' is nil.") + +(defvar autoload-timestamps nil ; experimental, see bug#22213 + "Non-nil means insert a timestamp for each input file into the output. +We use these in incremental updates of the output file to decide +if we need to rescan an input file. If you set this to nil, +then we use the timestamp of the output file instead. As a result: + - for fixed inputs, the output will be the same every time + - incremental updates of the output file might not be correct if: + i) the timestamp of the output file cannot be trusted (at least + relative to that of the input files) + ii) any of the input files can be modified during the time it takes + to create the output + iii) only a subset of the input files are scanned + These issues are unlikely to happen in practice, and would arguably + represent bugs in the build system. Item iii) will happen if you + use a command like `update-file-autoloads', though, since it only + checks a single input file.") + (defvar autoload-modified-buffers) ;Dynamically scoped var. (defun make-autoload (form file &optional expansion) @@ -160,10 +183,12 @@ expression, in which case we want to handle forms differently." (args (pcase car ((or `defun `defmacro `defun* `defmacro* `cl-defun `cl-defmacro - `define-overloadable-function) (nth 2 form)) + `define-overloadable-function) + (nth 2 form)) (`define-skeleton '(&optional str arg)) ((or `define-generic-mode `define-derived-mode - `define-compilation-mode) nil) + `define-compilation-mode) + nil) (_ t))) (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) (doc (if (stringp (car body)) (pop body)))) @@ -179,7 +204,8 @@ expression, in which case we want to handle forms differently." define-global-minor-mode define-globalized-minor-mode easy-mmode-define-minor-mode - define-minor-mode)) t) + define-minor-mode)) + t) (eq (car-safe (car body)) 'interactive)) ,(if macrop ''macro nil)))) @@ -234,9 +260,22 @@ If a buffer is visiting the desired autoload file, return it." (enable-local-eval nil)) ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (let ((delay-mode-hooks t)) - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file)))))) + (let* ((delay-mode-hooks t) + (file (autoload-generated-file)) + (file-missing (not (file-exists-p file)))) + (when file-missing + (autoload-ensure-default-file file)) + (with-current-buffer + (find-file-noselect + (autoload-ensure-file-writeable + file)) + ;; block backups when the file has just been created, since + ;; the backups will just be the auto-generated headers. + ;; bug#23203 + (when file-missing + (setq buffer-backed-up t) + (save-buffer)) + (current-buffer))))) (defun autoload-generated-file () (expand-file-name generated-autoload-file @@ -277,7 +316,7 @@ The variable `autoload-print-form-outbuf' specifies the buffer to put the output in." (cond ;; If the form is a sequence, recurse. - ((eq (car form) 'progn) (mapcar 'autoload-print-form (cdr form))) + ((eq (car form) 'progn) (mapcar #'autoload-print-form (cdr form))) ;; Symbols at the toplevel are meaningless. ((symbolp form) nil) (t @@ -357,25 +396,36 @@ not be relied upon." ;;;###autoload (put 'autoload-ensure-writable 'risky-local-variable t) +(defun autoload-ensure-file-writeable (file) + ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, + ;; which was designed to handle CVSREAD=1 and equivalent. + (and autoload-ensure-writable + (let ((modes (file-modes file))) + (if (zerop (logand modes #o0200)) + ;; Ignore any errors here, and let subsequent attempts + ;; to write the file raise any real error. + (ignore-errors (set-file-modes file (logior modes #o0200)))))) + file) + (defun autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists, creating it if needed. If the file already exists and `autoload-ensure-writable' is non-nil, make it writable." - (if (file-exists-p file) - ;; Probably pointless, but replaces the old AUTOGEN_VCS in lisp/Makefile, - ;; which was designed to handle CVSREAD=1 and equivalent. - (and autoload-ensure-writable - (let ((modes (file-modes file))) - (if (zerop (logand modes #o0200)) - ;; Ignore any errors here, and let subsequent attempts - ;; to write the file raise any real error. - (ignore-errors (set-file-modes file (logior modes #o0200)))))) - (write-region (autoload-rubric file) nil file)) - file) + (write-region (autoload-rubric file) nil file)) (defun autoload-insert-section-header (outbuf autoloads load-name file time) "Insert the section-header line, which lists the file name and which functions are in it, etc." + ;; (cl-assert ;Make sure we don't insert it in the middle of another section. + ;; (save-excursion + ;; (or (not (re-search-backward + ;; (concat "\\(" + ;; (regexp-quote generate-autoload-section-header) + ;; "\\)\\|\\(" + ;; (regexp-quote generate-autoload-section-trailer) + ;; "\\)") + ;; nil t)) + ;; (match-end 2)))) (insert generate-autoload-section-header) (prin1 `(autoloads ,autoloads ,load-name ,file ,time) outbuf) @@ -434,7 +484,7 @@ which lists the file name and which functions are in it, etc." ;; without checking its content. This makes it generate wrong load ;; names for cases like lisp/term which is not added to load-path. (setq dir (expand-file-name (pop names) dir))) - (t (setq name (mapconcat 'identity names "/"))))) + (t (setq name (mapconcat #'identity names "/"))))) (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) (substring name 0 (match-beginning 0)) name))) @@ -450,8 +500,116 @@ Return non-nil in the case where no autoloads were added at point." (let ((generated-autoload-file buffer-file-name)) (autoload-generate-file-autoloads file (current-buffer)))) -(defvar print-readably) - +(defvar autoload-compute-prefixes t + "If non-nil, autoload will add code to register the prefixes used in a file. +Standard prefixes won't be registered anyway. I.e. if a file \"foo.el\" defines +variables or functions that use \"foo-\" as prefix, that will not be registered. +But all other prefixes will be included.") + +(defconst autoload-def-prefixes-max-entries 5 + "Target length of the list of definition prefixes per file. +If set too small, the prefixes will be too generic (i.e. they'll use little +memory, we'll end up looking in too many files when we need a particular +prefix), and if set too large, they will be too specific (i.e. they will +cost more memory use).") + +(defconst autoload-def-prefixes-max-length 12 + "Target size of definition prefixes. +Don't try to split prefixes that are already longer than that.") + +(require 'radix-tree) + +(defun autoload--make-defs-autoload (defs file) + + ;; Remove the defs that obey the rule that file foo.el (or + ;; foo-mode.el) uses "foo-" as prefix. + ;; FIXME: help--symbol-completion-table still doesn't know how to use + ;; the rule that file foo.el (or foo-mode.el) uses "foo-" as prefix. + ;;(let ((prefix + ;; (concat (substring file 0 (string-match "-mode\\'" file)) "-"))) + ;; (dolist (def (prog1 defs (setq defs nil))) + ;; (unless (string-prefix-p prefix def) + ;; (push def defs)))) + + ;; Then compute a small set of prefixes that cover all the + ;; remaining definitions. + (let* ((tree (let ((tree radix-tree-empty)) + (dolist (def defs) + (setq tree (radix-tree-insert tree def t))) + tree)) + (prefixes nil)) + ;; Get the root prefixes, that we should include in any case. + (radix-tree-iter-subtrees + tree (lambda (prefix subtree) + (push (cons prefix subtree) prefixes))) + ;; In some cases, the root prefixes are too short, e.g. if you define + ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. + (dolist (pair (prog1 prefixes (setq prefixes nil))) + (let ((s (car pair))) + (if (or (> (length s) 2) ;Long enough! + (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? + (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! + (push pair prefixes) ;Keep it as is. + (radix-tree-iter-subtrees + (cdr pair) (lambda (prefix subtree) + (push (cons (concat s prefix) subtree) prefixes)))))) + ;; FIXME: The expansions done below are mostly pointless, such as + ;; for `yenc', where we replace "yenc-" with an exhaustive list (5 + ;; elements). + ;; (while + ;; (let ((newprefixes nil) + ;; (changes nil)) + ;; (dolist (pair prefixes) + ;; (let ((prefix (car pair))) + ;; (if (or (> (length prefix) autoload-def-prefixes-max-length) + ;; (radix-tree-lookup (cdr pair) "")) + ;; ;; No point splitting it any further. + ;; (push pair newprefixes) + ;; (setq changes t) + ;; (radix-tree-iter-subtrees + ;; (cdr pair) (lambda (sprefix subtree) + ;; (push (cons (concat prefix sprefix) subtree) + ;; newprefixes)))))) + ;; (and changes + ;; (<= (length newprefixes) + ;; autoload-def-prefixes-max-entries) + ;; (let ((new nil) + ;; (old nil)) + ;; (dolist (pair prefixes) + ;; (unless (memq pair newprefixes) ;Not old + ;; (push pair old))) + ;; (dolist (pair newprefixes) + ;; (unless (memq pair prefixes) ;Not new + ;; (push pair new))) + ;; (cl-assert new) + ;; (message "Expanding %S to %S" + ;; (mapcar #'car old) (mapcar #'car new)) + ;; t) + ;; (setq prefixes newprefixes) + ;; (< (length prefixes) autoload-def-prefixes-max-entries)))) + + ;; (message "Final prefixes %s : %S" file (mapcar #'car prefixes)) + (when prefixes + (let ((strings + (mapcar + (lambda (x) + (let ((prefix (car x))) + (if (or (> (length prefix) 2) ;Long enough! + (string-match ".[[:punct:]]\\'" prefix)) + prefix + ;; Some packages really don't follow the rules. + ;; Drop the most egregious cases such as the + ;; one-letter prefixes. + (let ((dropped ())) + (radix-tree-iter-mappings + (cdr x) (lambda (s _) + (push (concat prefix s) dropped))) + (message "Not registering prefix \"%s\" from %s. Affects: %S" + prefix file dropped) + nil)))) + prefixes))) + `(if (fboundp 'register-definition-prefixes) + (register-definition-prefixes ,file ',(delq nil strings))))))) (defun autoload--setup-output (otherbuf outbuf absfile load-name) (let ((outbuf @@ -529,11 +687,11 @@ FILE's modification time." (let (load-name (print-length nil) (print-level nil) - (print-readably t) ; This does something in Lucid Emacs. (float-output-format nil) (visited (get-file-buffer file)) (otherbuf nil) (absfile (expand-file-name file)) + (defs '()) ;; nil until we found a cookie. output-start) (when @@ -578,27 +736,93 @@ 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 - (forward-sexp 1) - (forward-line 1)))))) + ;; 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. + (when (and (equal generate-autoload-cookie ";;;###autoload") + (looking-at "(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]") + (not (member + (match-string 1) + '("define-obsolete-function-alias" + "define-obsolete-variable-alias" + "define-category" "define-key" + "defgroup" "defface" "defadvice" + "def-edebug-spec" + ;; Hmm... this is getting ugly: + "define-widget" + "define-erc-response-handler" + "defun-rcirc-command")))) + (push (match-string 2) defs)) + (forward-sexp 1) + (forward-line 1))))))) + + (when (and autoload-compute-prefixes defs) + ;; This output needs to always go in the main loaddefs.el, + ;; regardless of generated-autoload-file. + ;; FIXME: the files that don't have autoload cookies but + ;; do have definitions end up listed twice in loaddefs.el: + ;; once for their register-definition-prefixes and once in + ;; the list of "files without any autoloads". + (let ((form (autoload--make-defs-autoload defs load-name))) + (cond + ((null form)) ;All defs obey the default rule, yay! + ((not otherbuf) + (unless output-start + (setq output-start (autoload--setup-output + nil outbuf absfile load-name))) + (let ((autoload-print-form-outbuf + (marker-buffer output-start))) + (autoload-print-form form))) + (t + (let* ((other-output-start + ;; To force the output to go to the main loaddefs.el + ;; rather than to generated-autoload-file, + ;; there are two cases: if outbuf is non-nil, + ;; then passing otherbuf=nil is enough, but if + ;; outbuf is nil, that won't cut it, so we + ;; locally bind generated-autoload-file. + (let ((generated-autoload-file + (default-value 'generated-autoload-file))) + (autoload--setup-output nil outbuf absfile load-name))) + (autoload-print-form-outbuf + (marker-buffer other-output-start))) + (autoload-print-form form) + (with-current-buffer (marker-buffer other-output-start) + (save-excursion + ;; Insert the section-header line which lists + ;; the file name and which functions are in it, etc. + (goto-char other-output-start) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer other-output-start) + "actual autoloads are elsewhere" load-name relfile + (if autoload-timestamps + (nth 5 (file-attributes absfile)) + autoload--non-timestamp)) + (insert ";;; Generated autoloads from " relfile "\n"))) + (insert generate-autoload-section-trailer))))))) (when output-start (let ((secondary-autoloads-file-buf (if otherbuf (current-buffer)))) (with-current-buffer (marker-buffer output-start) + (cl-assert (> (point) output-start)) (save-excursion ;; Insert the section-header line which lists the file name ;; and which functions are in it, etc. @@ -624,7 +848,9 @@ FILE's modification time." ;; We'd really want to just use ;; `emacs-internal' instead. nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) + (if autoload-timestamps + (nth 5 (file-attributes relfile)) + autoload--non-timestamp))) (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) (or noninteractive @@ -655,6 +881,8 @@ FILE's modification time." (let ((version-control 'never)) (save-buffer))))) +;; FIXME This command should be deprecated. +;; See http://debbugs.gnu.org/22213#41 ;;;###autoload (defun update-file-autoloads (file &optional save-after outfile) "Update the autoloads for FILE. @@ -672,6 +900,9 @@ Return FILE if there was no autoload cookie in it, else nil." (read-file-name "Write autoload definitions to file: "))) (let* ((generated-autoload-file (or outfile generated-autoload-file)) (autoload-modified-buffers nil) + ;; We need this only if the output file handles more than one input. + ;; See http://debbugs.gnu.org/22213#38 and subsequent. + (autoload-timestamps t) (no-autoloads (autoload-generate-file-autoloads file))) (if autoload-modified-buffers (if save-after (autoload-save-buffers)) @@ -682,12 +913,16 @@ Return FILE if there was no autoload cookie in it, else nil." (defun autoload-find-destination (file load-name) "Find the destination point of the current buffer's autoloads. FILE is the file name of the current buffer. +LOAD-NAME is the name as it appears in the output. Returns a buffer whose point is placed at the requested location. -Returns nil if the file's autoloads are uptodate, otherwise +Returns nil if the file's autoloads are up-to-date, otherwise removes any prior now out-of-date autoload entries." (catch 'up-to-date (let* ((buf (current-buffer)) (existing-buffer (if buffer-file-name buf)) + (output-file (autoload-generated-file)) + (output-time (if (file-exists-p output-file) + (nth 5 (file-attributes output-file)))) (found nil)) (with-current-buffer (autoload-find-generated-file) ;; This is to make generated-autoload-file have Unix EOLs, so @@ -712,16 +947,28 @@ removes any prior now out-of-date autoload entries." (file-time (nth 5 (file-attributes file)))) (if (and (or (null existing-buffer) (not (buffer-modified-p existing-buffer))) - (or + (cond + ;; FIXME? Arguably we should throw a + ;; user error, or some kind of warning, + ;; if we were called from update-file-autoloads, + ;; which can update only a single input file. + ;; It's not appropriate to use the output + ;; file modtime in such a case, + ;; if there are multiple input files + ;; contributing to the output. + ((and output-time + (member last-time + (list t autoload--non-timestamp))) + (not (time-less-p output-time file-time))) ;; last-time is the time-stamp (specifying ;; the last time we looked at the file) and ;; the file hasn't been changed since. - (and (listp last-time) (= (length last-time) 2) - (not (time-less-p last-time file-time))) + ((listp last-time) + (not (time-less-p last-time file-time))) ;; last-time is an MD5 checksum instead. - (and (stringp last-time) - (equal last-time - (md5 buf nil nil 'emacs-mule))))) + ((stringp last-time) + (equal last-time + (md5 buf nil nil 'emacs-mule))))) (throw 'up-to-date nil) (autoload-remove-section begin) (setq found t)))) @@ -765,14 +1012,20 @@ write its autoloads into the specified file instead." (interactive "DUpdate autoloads from directory: ") (let* ((files-re (let ((tmp nil)) (dolist (suf (get-load-suffixes)) - (unless (string-match "\\.elc" suf) (push suf tmp))) + ;; We don't use module-file-suffix below because + ;; we don't want to depend on whether Emacs was + ;; built with or without modules support, nor + ;; what is the suffix for the underlying OS. + (unless (string-match "\\.\\(elc\\|\\so\\|dll\\)" suf) + (push suf tmp))) (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) - (files (apply 'nconc + (files (apply #'nconc (mapcar (lambda (dir) (directory-files (expand-file-name dir) t files-re)) dirs))) - (done ()) + (done ()) ;Files processed; to remove duplicates. + (changed nil) ;Non-nil if some change occurred. (last-time) ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. @@ -781,13 +1034,16 @@ write its autoloads into the specified file instead." (generated-autoload-file (if (called-interactively-p 'interactive) (read-file-name "Write autoload definitions to file: ") - generated-autoload-file))) + generated-autoload-file)) + (output-time + (if (file-exists-p generated-autoload-file) + (nth 5 (file-attributes generated-autoload-file))))) (with-current-buffer (autoload-find-generated-file) (save-excursion ;; Canonicalize file names and remove the autoload file itself. (setq files (delete (file-relative-name buffer-file-name) - (mapcar 'file-relative-name files))) + (mapcar #'file-relative-name files))) (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) @@ -799,6 +1055,8 @@ write its autoloads into the specified file instead." ;; Remove the obsolete section. (autoload-remove-section (match-beginning 0)) (setq last-time (nth 4 form)) + (if (member last-time (list t autoload--non-timestamp)) + (setq last-time output-time)) (dolist (file file) (let ((file-time (nth 5 (file-attributes file)))) (when (and file-time @@ -809,16 +1067,21 @@ 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))) - ((not (time-less-p (nth 4 form) + ((not (time-less-p (let ((oldtime (nth 4 form))) + (if (member oldtime + (list + t autoload--non-timestamp)) + output-time + oldtime)) (nth 5 (file-attributes file)))) ;; File hasn't changed. nil) (t + (setq changed t) (autoload-remove-section (match-beginning 0)) (if (autoload-generate-file-autoloads ;; Passing `current-buffer' makes it insert at point. @@ -830,7 +1093,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. @@ -838,7 +1100,8 @@ write its autoloads into the specified file instead." (autoload-generate-file-autoloads file nil buffer-file-name)) (push file no-autoloads) (if (time-less-p no-autoloads-time file-time) - (setq no-autoloads-time file-time))))) + (setq no-autoloads-time file-time))) + (t (setq changed t)))) (when no-autoloads ;; Sort them for better readability. @@ -847,11 +1110,18 @@ write its autoloads into the specified file instead." (goto-char (point-max)) (search-backward "\f" nil t) (autoload-insert-section-header - (current-buffer) nil nil no-autoloads no-autoloads-time) + (current-buffer) nil nil no-autoloads (if autoload-timestamps + no-autoloads-time + autoload--non-timestamp)) (insert generate-autoload-section-trailer))) - (let ((version-control 'never)) - (save-buffer)) + ;; Don't modify the file if its content has not been changed, so `make' + ;; dependencies don't trigger unnecessarily. + (if (not changed) + (set-buffer-modified-p nil) + (let ((version-control 'never)) + (save-buffer))) + ;; In case autoload entries were added to other files because of ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) @@ -883,7 +1153,7 @@ should be non-nil)." (push (expand-file-name file) autoload-excludes))))))) (let ((args command-line-args-left)) (setq command-line-args-left nil) - (apply 'update-directory-autoloads args))) + (apply #'update-directory-autoloads args))) (provide 'autoload) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 99a329b021e..707d1cbd1ff 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,6 +1,6 @@ ;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*- -;; Copyright (C) 1995, 2007-2015 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2016 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> @@ -98,7 +98,8 @@ ;; avl-tree-right avl-tree-data] branch) node) "Get value of a branch of a node. NODE is the node, and BRANCH is the branch. -0 for left pointer, 1 for right pointer and 2 for the data.") +0 for left pointer, 1 for right pointer and 2 for the data. +\n(fn BRANCH NODE)") ;; The funcall/aref trick wouldn't work for the setf method, unless we @@ -400,7 +401,8 @@ itself." reverse store) (defalias 'avl-tree-stack-p #'avl-tree--stack-p - "Return t if argument is an avl-tree-stack, nil otherwise.") + "Return t if OBJ is an avl-tree-stack, nil otherwise. +\n(fn OBJ)") (defun avl-tree--stack-repopulate (stack) ;; Recursively push children of the node at the head of STACK onto the @@ -419,12 +421,12 @@ itself." (defalias 'avl-tree-create #'avl-tree--create "Create an empty AVL tree. COMPARE-FUNCTION is a function which takes two arguments, A and B, -and returns non-nil if A is less than B, and nil otherwise.") +and returns non-nil if A is less than B, and nil otherwise. +\n(fn COMPARE-FUNCTION)") (defalias 'avl-tree-compare-function #'avl-tree--cmpfun "Return the comparison function for the AVL tree TREE. - -\(fn TREE)") +\n(fn TREE)") (defun avl-tree-empty (tree) "Return t if AVL tree TREE is empty, otherwise return nil." @@ -561,7 +563,7 @@ Note that if you don't care about the order in which FUNCTION is applied, just that the resulting list is in the correct order, then - (avl-tree-mapf function 'cons tree (not reverse)) + (avl-tree-mapf function \\='cons tree (not reverse)) is more efficient." (nreverse (avl-tree-mapf fun 'cons tree reverse))) diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index dc61e156130..c31f25c7957 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,6 +1,6 @@ ;;; backquote.el --- implement the ` Lisp construct -;; Copyright (C) 1990, 1992, 1994, 2001-2015 Free Software Foundation, +;; Copyright (C) 1990, 1992, 1994, 2001-2016 Free Software Foundation, ;; Inc. ;; Author: Rick Sladkey <jrs@world.std.com> @@ -43,7 +43,7 @@ (defun backquote-list*-function (first &rest list) "Like `list' but the last argument is the tail of the new list. -For example (backquote-list* 'a 'b 'c) => (a b . c)" +For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" ;; The recursive solution is much nicer: ;; (if list (cons first (apply 'backquote-list*-function list)) first)) ;; but Emacs is not very good at efficiently processing recursion. @@ -60,7 +60,7 @@ For example (backquote-list* 'a 'b 'c) => (a b . c)" (defmacro backquote-list*-macro (first &rest list) "Like `list' but the last argument is the tail of the new list. -For example (backquote-list* 'a 'b 'c) => (a b . c)" +For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" ;; The recursive solution is much nicer: ;; (if list (list 'cons first (cons 'backquote-list*-macro list)) first)) ;; but Emacs is not very good at efficiently processing such things. diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index dc1b44e3164..613cfa27d77 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,6 +1,6 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003-2015 Free Software Foundation, Inc. +;; Copyright (C) 2003-2016 Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 2aa636e4e82..84d62ee127f 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -1,6 +1,6 @@ ;;; bindat.el --- binary data structure packing and unpacking. -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Kim F. Storm <storm@cua.dk> ;; Assignment name: struct.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c3c61d6c81e..610c3b6c190 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,6 +1,6 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- -;; Copyright (C) 1991, 1994, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2016 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -288,8 +288,8 @@ (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. - (byte-compile-log-warning - (format "Inlining closure %S failed" name)) + (byte-compile-warn + "Inlining closure %S failed" name) form)))) (_ ;; Give up on inlining. @@ -1209,8 +1209,9 @@ radians-to-degrees rassq rassoc read-from-string regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring sxhash symbol-function - symbol-name symbol-plist symbol-value string-make-unibyte + string-to-int string-to-number substring + sxhash sxhash-equal sxhash-eq sxhash-eql + symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte tan truncate diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 73c2977e8eb..818c2683463 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,6 +1,6 @@ ;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*- -;; Copyright (C) 1992, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2016 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -362,6 +362,9 @@ is equivalent to the following two lines of code: \(defalias \\='old-fun \\='new-fun \"old-fun's doc.\") \(make-obsolete \\='old-fun \\='new-fun \"22.1\") +If provided, WHEN should be a string indicating when the function +was first made obsolete, for example a date or a release number. + See the docstrings of `defalias' and `make-obsolete' for more details." (declare (doc-string 4) (advertised-calling-convention @@ -404,6 +407,9 @@ dumped with Emacs). This is so that any user customizations are applied before the defcustom tries to initialize the variable (this is due to the way `defvaralias' works). +If provided, WHEN should be a string indicating when the variable +was first made obsolete, for example a date or a release number. + For the benefit of `custom-set-variables', if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: @@ -428,8 +434,8 @@ CURRENT-NAME, if it does not already have them: ;; It only really affects M-x describe-face output. (defmacro define-obsolete-face-alias (obsolete-face current-face when) "Make OBSOLETE-FACE a face alias for CURRENT-FACE and mark it obsolete. -The string WHEN gives the Emacs version where OBSOLETE-FACE became -obsolete." +If provided, WHEN should be a string indicating when the face +was first made obsolete, for example a date or a release number." `(progn (put ,obsolete-face 'face-alias ,current-face) ;; Used by M-x describe-face. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index db200f3c504..85daa43eaed 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,6 +1,6 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- -;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2015 Free Software +;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2016 Free Software ;; Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> @@ -265,8 +265,8 @@ This option is enabled by default because it reduces Emacs memory usage." (defcustom byte-optimize-log nil "If non-nil, the byte-compiler will log its optimizations. -If this is 'source, then only source-level optimizations will be logged. -If it is 'byte, then only byte-level optimizations will be logged. +If this is `source', then only source-level optimizations will be logged. +If it is `byte', then only byte-level optimizations will be logged. The information is logged to `byte-compile-log-buffer'." :group 'bytecomp :type '(choice (const :tag "none" nil) @@ -456,10 +456,20 @@ Return the compile-time value of FORM." (byte-compile-recurse-toplevel (macroexp-progn body) (lambda (form) - (setf result - (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form)))))) + ;; Insulate the following variables + ;; against changes made in the + ;; subsidiary compilation. This + ;; prevents spurious warning + ;; messages: "not defined at runtime" + ;; etc. + (let ((byte-compile-unresolved-functions + byte-compile-unresolved-functions) + (byte-compile-new-defuns + byte-compile-new-defuns)) + (setf result + (byte-compile-eval + (byte-compile-top-level + (byte-compile-preprocess form))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -503,6 +513,11 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +(defvar byte-compile-new-defuns nil + "List of (runtime) functions defined in this compilation run. +This variable is used to qualify `byte-compile-noruntime-functions' when +outputting warnings about functions not being defined at runtime.") + ;; Variables for lexical binding (defvar byte-compile--lexical-environment nil "The current lexical environment.") @@ -1007,39 +1022,42 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setcdr list (cddr list))) total))) -;; The purpose of this function is to iterate through the -;; `read-symbol-positions-list'. Each time we process, say, a -;; function definition (`defun') we remove `defun' from -;; `read-symbol-positions-list', and set `byte-compile-last-position' -;; to that symbol's character position. Similarly, if we encounter a -;; variable reference, like in (1+ foo), we remove `foo' from the -;; list. If our current position is after the symbol's position, we -;; assume we've already passed that point, and look for the next -;; occurrence of the symbol. +;; The purpose of `byte-compile-set-symbol-position' is to attempt to +;; set `byte-compile-last-position' to the "current position" in the +;; raw source code. This is used for warning and error messages. +;; +;; The function should be called for most occurrences of symbols in +;; the forms being compiled, strictly in the order they occur in the +;; source code. It should never be called twice for any single +;; occurrence, and should not be called for symbols generated by the +;; byte compiler itself. ;; -;; This function should not be called twice for the same occurrence of -;; a symbol, and it should not be called for symbols generated by the -;; byte compiler itself; because rather than just fail looking up the -;; symbol, we may find an occurrence of the symbol further ahead, and -;; then `byte-compile-last-position' as advanced too far. +;; The function works by scanning the elements in the alist +;; `read-symbol-positions-list' for the next match for the symbol +;; after the current value of `byte-compile-last-position', setting +;; that variable to the match's character position, then deleting the +;; matching element from the list. Thus the new value for +;; `byte-compile-last-position' is later than the old value unless, +;; perhaps, ALLOW-PREVIOUS is non-nil. ;; -;; So your're probably asking yourself: Isn't this function a -;; gross hack? And the answer, of course, would be yes. +;; So your're probably asking yourself: Isn't this function a gross +;; hack? And the answer, of course, would be yes. (defun byte-compile-set-symbol-position (sym &optional allow-previous) (when byte-compile-read-position - (let (last entry) + (let ((last byte-compile-last-position) + entry) (while (progn - (setq last byte-compile-last-position - entry (assq sym read-symbol-positions-list)) + (setq entry (assq sym read-symbol-positions-list)) (when entry (setq byte-compile-last-position (+ byte-compile-read-position (cdr entry)) read-symbol-positions-list (byte-compile-delete-first entry read-symbol-positions-list))) - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position))))))) + (and entry + (or (and allow-previous + (not (= last byte-compile-last-position))) + (> last byte-compile-last-position)))))))) (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) @@ -1145,16 +1163,20 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (compilation-forget-errors) pt)))) -;; Log a message STRING in `byte-compile-log-buffer'. -;; Also log the current function and file if not already done. (defun byte-compile-log-warning (string &optional fill level) + "Log a message STRING in `byte-compile-log-buffer'. +Also log the current function and file if not already done. If +FILL is non-nil, set `warning-fill-prefix' to four spaces. LEVEL +is the warning level (`:warning' or `:error'). Do not call this +function directly; use `byte-compile-warn' or +`byte-compile-report-error' instead." (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") (warning-fill-prefix (if fill " "))) (display-warning 'bytecomp string level byte-compile-log-buffer))) (defun byte-compile-warn (format &rest args) - "Issue a byte compiler warning; use (format FORMAT ARGS...) for message." + "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it @@ -1171,15 +1193,16 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) (byte-compile-warn "%s" msg))))) -(defun byte-compile-report-error (error-info) +(defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA) -or STRING." +or STRING. If FILL is non-nil, set ‘warning-fill-prefix’ to four spaces +when printing the error message." (setq byte-compiler-error-flag t) (byte-compile-log-warning (if (stringp error-info) error-info (error-message-string error-info)) - nil :error)) + fill :error)) ;;; sanity-checking arglists @@ -1264,6 +1287,7 @@ or STRING." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) + (byte-compile-set-symbol-position f) (when (get f 'byte-obsolete-info) (byte-compile-warn-obsolete f)) @@ -1345,31 +1369,33 @@ extra args." (dolist (elt '(format message error)) (put elt 'byte-compile-format-like t)) -;; Warn if a custom definition fails to specify :group. +;; Warn if a custom definition fails to specify :group, or :type. (defun byte-compile-nogroup-warn (form) - (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) - byte-compile-current-group) - ;; The group will be provided implicitly. - nil - (let ((keyword-args (cdr (cdr (cdr (cdr form))))) - (name (cadr form))) - (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) - '((custom-declare-group . defgroup) - (custom-declare-face . defface) - (custom-declare-variable . defcustom)))) - (cadr name))) - ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when compiling a whole file. - (eq (car form) 'custom-declare-group) - (eq (car-safe name) 'quote)) - (setq byte-compile-current-group (cadr name)))))) + (let ((keyword-args (cdr (cdr (cdr (cdr form))))) + (name (cadr form))) + (when (eq (car-safe name) 'quote) + (or (not (eq (car form) 'custom-declare-variable)) + (plist-get keyword-args :type) + (byte-compile-warn + "defcustom for `%s' fails to specify type" (cadr name))) + (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) + byte-compile-current-group) + ;; The group will be provided implicitly. + nil + (or (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) + '((custom-declare-group . defgroup) + (custom-declare-face . defface) + (custom-declare-variable . defcustom)))) + (cadr name))) + ;; Update the current group, if needed. + (if (and byte-compile-current-file ;Only when compiling a whole file. + (eq (car form) 'custom-declare-group)) + (setq byte-compile-current-group (cadr name))))))) ;; Warn if the function or macro is being redefined with a different ;; number of arguments. @@ -1503,8 +1529,9 @@ extra args." ;; Separate the functions that will not be available at runtime ;; from the truly unresolved ones. (dolist (f byte-compile-unresolved-functions) - (setq f (car f)) - (if (fboundp f) (push f noruntime) (push f unresolved))) + (setq f (car f)) + (when (not (memq f byte-compile-new-defuns)) + (if (fboundp f) (push f noruntime) (push f unresolved)))) ;; Complain about the no-run-time functions (byte-compile-print-syms "the function `%s' might not be defined at runtime." @@ -1691,7 +1718,7 @@ Any other non-nil value of ARG means to ask the user. If optional argument LOAD is non-nil, loads the file after compiling. If compilation is needed, this functions returns the result of -`byte-compile-file'; otherwise it returns 'no-byte-compile." +`byte-compile-file'; otherwise it returns `no-byte-compile'." (interactive (let ((file buffer-file-name) (file-name nil) @@ -1865,12 +1892,13 @@ The value is non-nil if there were no errors, nil if errors." (rename-file tempfile target-file t) (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file))) + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -1961,6 +1989,8 @@ With argument ARG, insert value in current buffer after the form." ;; compiled. A: Yes! b-c-u-f might contain dross from a ;; previous byte-compile. (setq byte-compile-unresolved-functions nil) + (setq byte-compile-noruntime-functions nil) + (setq byte-compile-new-defuns nil) ;; Compile the forms from the input buffer. (while (progn @@ -2287,8 +2317,7 @@ list that represents a doc string reference. ;; byte-compile-warn-about-unresolved-functions. (if (memq funsym byte-compile-noruntime-functions) (setq byte-compile-noruntime-functions - (delq funsym byte-compile-noruntime-functions) - byte-compile-noruntime-functions) + (delq funsym byte-compile-noruntime-functions)) (setq byte-compile-unresolved-functions (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) @@ -2346,8 +2375,21 @@ list that represents a doc string reference. (defun byte-compile-file-form-require (form) (let ((args (mapcar 'eval (cdr form))) (hist-orig load-history) - hist-new) + hist-new prov-cons) (apply 'require args) + + ;; Record the functions defined by the require in `byte-compile-new-defuns'. + (setq hist-new load-history) + (setq prov-cons (cons 'provide (car args))) + (while (and hist-new + (not (member prov-cons (car hist-new)))) + (setq hist-new (cdr hist-new))) + (when hist-new + (dolist (x (car hist-new)) + (when (and (consp x) + (memq (car x) '(defun t))) + (push (cdr x) byte-compile-new-defuns)))) + (when (byte-compile-warning-enabled-p 'cl-functions) ;; Detect (require 'cl) in a way that works even if cl is already loaded. (if (member (car args) '("cl" cl)) @@ -2403,6 +2445,7 @@ not to take responsibility for the actual compilation of the code." (byte-compile-current-form name)) ; For warnings. (byte-compile-set-symbol-position name) + (push name byte-compile-new-defuns) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree @@ -2549,7 +2592,13 @@ FUN should be either a `lambda' value or a `closure' value." (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) `(closure ,env ,args . ,body)) fun) + (preamble nil) (renv ())) + ;; Split docstring and `interactive' form from body. + (when (stringp (car body)) + (push (pop body) preamble)) + (when (eq (car-safe (car body)) 'interactive) + (push (pop body) preamble)) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -2562,8 +2611,8 @@ FUN should be either a `lambda' value or a `closure' value." ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) - `(lambda ,args ,@body) - `(lambda ,args (let ,(nreverse renv) ,@body))))) + `(lambda ,args ,@preamble ,@body) + `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2623,8 +2672,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (cddr list) (error "Garbage following &rest VAR in lambda-list"))) ((eq arg '&optional) - (unless (cdr list) - (error "Variable name missing after &optional"))) + (when (or (null (cdr list)) + (memq (cadr list) '(&optional &rest))) + (error "Variable name missing after &optional")) + (when (memq '&optional (cddr list)) + (error "Duplicate &optional"))) ((memq arg vars) (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t @@ -2926,6 +2978,8 @@ for symbols generated by the byte compiler itself." ;; Special macro-expander used during byte-compilation. (defun byte-compile-macroexpand-declare-function (fn file &rest args) + (declare (advertised-calling-convention + (fn file &optional arglist fileonly) nil)) (let ((gotargs (and (consp args) (listp (car args)))) (unresolved (assq fn byte-compile-unresolved-functions))) (when unresolved ; function was called before declaration @@ -2984,9 +3038,8 @@ for symbols generated by the byte compiler itself." (pcase (cdr form) (`(',var . ,_) (when (assq var byte-compile-lexical-variables) - (byte-compile-log-warning - (format-message "%s cannot use lexical var `%s'" fn var) - nil :error))))) + (byte-compile-report-error + (format-message "%s cannot use lexical var `%s'" fn var)))))) (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only) @@ -3003,9 +3056,8 @@ for symbols generated by the byte compiler itself." interactive-only)) (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-log-warning - (format "Forgot to expand macro %s in %S" (car form) form) - nil :error)) + (byte-compile-report-error + (format "Forgot to expand macro %s in %S" (car form) form))) (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3102,9 +3154,8 @@ 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 - (format "Too many arguments for inlined function %S" form) - nil :error) + (byte-compile-report-error + (format "Too many arguments for inlined function %S" form)) (byte-compile-discard (- alen (/ fmax2 2)))) (t ;; Turn &rest args into a list. @@ -3710,16 +3761,25 @@ discarding." (byte-defop-compiler-1 quote) (defun byte-compile-setq (form) - (let ((args (cdr form))) - (if args - (while args - (byte-compile-form (car (cdr args))) - (or byte-compile--for-effect (cdr (cdr args)) - (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-set (car args)) - (setq args (cdr (cdr args)))) - ;; (setq), with no arguments. - (byte-compile-form nil byte-compile--for-effect)) + (let* ((args (cdr form)) + (len (length args))) + (if (= (logand len 1) 1) + (progn + (byte-compile-report-error + (format-message + "missing value for `%S' at end of setq" (car (last args)))) + (byte-compile-form + `(signal 'wrong-number-of-arguments '(setq ,len)) + byte-compile--for-effect)) + (if args + (while args + (byte-compile-form (car (cdr args))) + (or byte-compile--for-effect (cdr (cdr args)) + (byte-compile-out 'byte-dup 0)) + (byte-compile-variable-set (car args)) + (setq args (cdr (cdr args)))) + ;; (setq), with no arguments. + (byte-compile-form nil byte-compile--for-effect))) (setq byte-compile--for-effect nil))) (defun byte-compile-setq-default (form) @@ -3973,8 +4033,14 @@ that suppresses all warnings during execution of BODY." (setq byte-compile--for-effect nil))) (defun byte-compile-funcall (form) - (mapc 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-call (length (cdr (cdr form))))) + (if (cdr form) + (progn + (mapc 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-call (length (cdr (cdr form))))) + (byte-compile-report-error + (format-message "`funcall' called with no arguments")) + (byte-compile-form '(signal 'wrong-number-of-arguments '(funcall 0)) + byte-compile--for-effect))) ;; let binding diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index efa9a3da011..46b5a7f342c 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,6 +1,6 @@ ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- -;; Copyright (C) 2011-2015 Free Software Foundation, Inc. +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> ;; Maintainer: emacs-devel@gnu.org @@ -253,6 +253,32 @@ Returns a form where all lambdas don't have any free variables." `(internal-make-closure ,args ,envector ,docstring . ,body-new))))) +(defun cconv--remap-llv (new-env var closedsym) + ;; In a case such as: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; A naive lambda-lifting would return + ;; (let* ((fun (lambda (y x) (+ x y))) (y 1)) (funcall fun y 1)) + ;; Where the external `y' is mistakenly captured by the inner one. + ;; So when we detect that case, we rewrite it to: + ;; (let* ((closed-y y) (fun (lambda (y x) (+ x y))) (y 1)) + ;; (funcall fun closed-y 1)) + ;; We do that even if there's no `funcall' that uses `fun' in the scope + ;; where `y' is shadowed by another variable because, to treat + ;; this case better, we'd need to traverse the tree one more time to + ;; collect this data, and I think that it's not worth it. + (mapcar (lambda (mapping) + (if (not (eq (cadr mapping) 'apply-partially)) + mapping + (cl-assert (eq (car mapping) (nth 2 mapping))) + `(,(car mapping) + apply-partially + ,(car mapping) + ,@(mapcar (lambda (arg) + (if (eq var arg) + closedsym arg)) + (nthcdr 3 mapping))))) + new-env)) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -299,9 +325,9 @@ places where they originally did not directly appear." (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-log-warning - (format-message "Malformed `%S' binding: %S" - letsym binder))) + (byte-compile-warn + "Malformed `%S' binding: %S" + letsym binder)) (setq value (cadr binder)) (car binder))) (new-val @@ -350,34 +376,13 @@ places where they originally did not directly appear." (if (assq var new-env) (push `(,var) new-env)) (cconv-convert value env extend))))) - ;; The piece of code below letbinds free variables of a λ-lifted - ;; function if they are redefined in this let, example: - ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) - ;; Here we can not pass y as parameter because it is redefined. - ;; So we add a (closed-y y) declaration. We do that even if the - ;; function is not used inside this let(*). The reason why we - ;; ignore this case is that we can't "look forward" to see if the - ;; function is called there or not. To treat this case better we'd - ;; need to traverse the tree one more time to collect this data, and - ;; I think that it's not worth it. - (when (memq var new-extend) - (let ((closedsym - (make-symbol (concat "closed-" (symbol-name var))))) - (setq new-env - (mapcar (lambda (mapping) - (if (not (eq (cadr mapping) 'apply-partially)) - mapping - (cl-assert (eq (car mapping) (nth 2 mapping))) - `(,(car mapping) - apply-partially - ,(car mapping) - ,@(mapcar (lambda (arg) - (if (eq var arg) - closedsym arg)) - (nthcdr 3 mapping))))) - new-env)) - (setq new-extend (remq var new-extend)) - (push closedsym new-extend) + (when (and (eq letsym 'let*) (memq var new-extend)) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let ((closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) (push `(,closedsym ,var) binders-new))) ;; We push the element after redefined free variables are @@ -390,6 +395,21 @@ places where they originally did not directly appear." (setq extend new-extend)) )) ; end of dolist over binders + (when (not (eq letsym 'let*)) + ;; We can't do the cconv--remap-llv at the same place for let and + ;; let* because in the case of `let', the shadowing may occur + ;; before we know that the var will be in `new-extend' (bug#24171). + (dolist (binder binders-new) + (when (memq (car-safe binder) new-extend) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let* ((var (car-safe binder)) + (closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var) binders-new))))) + `(,letsym ,(nreverse binders-new) . ,(mapcar (lambda (form) (cconv-convert @@ -473,25 +493,28 @@ places where they originally did not directly appear." :fun-body ,(cconv--convert-function () body env form))) (`(setq . ,forms) ; setq special form - (let ((prognlist ())) - (while forms - (let* ((sym (pop forms)) - (sym-new (or (cdr (assq sym env)) sym)) - (value (cconv-convert (pop forms) env extend))) - (push (pcase sym-new - ((pred symbolp) `(setq ,sym-new ,value)) - (`(car-safe ,iexp) `(setcar ,iexp ,value)) - ;; This "should never happen", but for variables which are - ;; mutated+captured+unused, we may end up trying to `setq' - ;; on a closed-over variable, so just drop the setq. - (_ ;; (byte-compile-report-error - ;; (format "Internal error in cconv of (setq %s ..)" - ;; sym-new)) - value)) - prognlist))) - (if (cdr prognlist) - `(progn . ,(nreverse prognlist)) - (car prognlist)))) + (if (= (logand (length forms) 1) 1) + ;; With an odd number of args, let bytecomp.el handle the error. + form + (let ((prognlist ())) + (while forms + (let* ((sym (pop forms)) + (sym-new (or (cdr (assq sym env)) sym)) + (value (cconv-convert (pop forms) env extend))) + (push (pcase sym-new + ((pred symbolp) `(setq ,sym-new ,value)) + (`(car-safe ,iexp) `(setcar ,iexp ,value)) + ;; This "should never happen", but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (_ ;; (byte-compile-report-error + ;; (format "Internal error in cconv of (setq %s ..)" + ;; sym-new)) + value)) + prognlist))) + (if (cdr prognlist) + `(progn . ,(nreverse prognlist)) + (car prognlist))))) (`(,(and (or `funcall `apply) callsym) ,fun . ,args) ;; These are not special forms but we treat them separately for the needs @@ -545,8 +568,8 @@ FORM is the parent form that binds this var." (`(,_ nil nil nil nil) nil) (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) - (byte-compile-log-warning - (format-message "%s `%S' not left unused" varkind var)))) + (byte-compile-warn + "%s `%S' not left unused" varkind var))) (pcase vardata (`((,var . ,_) nil ,_ ,_ nil) ;; FIXME: This gives warnings in the wrong order, with imprecise line @@ -558,8 +581,8 @@ FORM is the parent form that binds this var." (eq ?_ (aref (symbol-name var) 0)) ;; As a special exception, ignore "ignore". (eq var 'ignored)) - (byte-compile-log-warning (format-message "Unused lexical %s `%S'" - varkind var)))) + (byte-compile-warn "Unused lexical %s `%S'" + varkind var))) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) @@ -583,9 +606,9 @@ FORM is the parent form that binds this var." (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-log-warning - (format "Lexical argument shadows the dynamic variable %S" - arg))) + (byte-compile-warn + "Lexical argument shadows the dynamic variable %S" + arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) (cl-pushnew arg byte-compile-lexical-variables) @@ -667,9 +690,8 @@ and updates the data stored in ENV." (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-log-warning - (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) - t :warning) + (byte-compile-warn + "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -678,8 +700,8 @@ and updates the data stored in ENV." (dolist (form forms) (cconv-analyze-form form env)))) ;; ((and `(quote ,v . ,_) (guard (assq v env))) - ;; (byte-compile-log-warning - ;; (format-message "Possible confusion variable/symbol for `%S'" v))) + ;; (byte-compile-warn + ;; "Possible confusion variable/symbol for `%S'" v)) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote @@ -696,8 +718,8 @@ and updates the data stored in ENV." (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-log-warning - (format "Lexical variable shadows the dynamic variable %S" var))) + (byte-compile-warn + "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 06601252a4c..962a85e90e7 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,6 +1,6 @@ ;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*- -;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2015 Free +;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2016 Free ;; Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -60,6 +60,8 @@ ;; with all the bitmaps you want to use. (require 'eieio) +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-generic)) ;;; Code: (define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") @@ -117,21 +119,13 @@ Useful if new Emacs is used on B&W display.") List is limited currently, which is ok since you really can't display too much in text characters anyways.") -(define-derived-mode chart-mode fundamental-mode "CHART" +(define-derived-mode chart-mode special-mode "Chart" "Define a mode in Emacs for displaying a chart." (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) (font-lock-mode -1) ;Isn't it off already? --Stef ) -(defun chart-new-buffer (obj) - "Create a new buffer NAME in which the chart OBJ is displayed. -Returns the newly created buffer." - (with-current-buffer (get-buffer-create (format "*%s*" (oref obj title))) - (chart-mode) - (setq chart-local-object obj) - (current-buffer))) - (defclass chart () ((title :initarg :title :initform "Emacs Chart") @@ -156,7 +150,15 @@ Returns the newly created buffer." ) "Superclass for all charts to be displayed in an Emacs buffer.") -(defmethod initialize-instance :AFTER ((obj chart) &rest _fields) +(defun chart-new-buffer (obj) + "Create a new buffer NAME in which the chart OBJ is displayed. +Returns the newly created buffer." + (with-current-buffer (get-buffer-create (format "*%s*" (oref obj title))) + (chart-mode) + (setq chart-local-object obj) + (current-buffer))) + +(cl-defmethod initialize-instance :after ((obj chart) &rest _fields) "Initialize the chart OBJ being created with FIELDS. Make sure the width/height is correct." (oset obj x-width (- (window-width) 10)) @@ -201,39 +203,40 @@ Make sure the width/height is correct." :initform vertical)) "Subclass for bar charts (vertical or horizontal).") -(defmethod chart-draw ((c chart) &optional buff) +(cl-defmethod chart-draw ((c chart) &optional buff) "Start drawing a chart object C in optional BUFF. Erases current contents of buffer." - (save-excursion - (if buff (set-buffer buff)) - (erase-buffer) - (insert (make-string 100 ?\n)) - ;; Start by displaying the axis - (chart-draw-axis c) - ;; Display title - (chart-draw-title c) - ;; Display data - (message "Rendering chart...") - (sit-for 0) - (chart-draw-data c) - ;; Display key - ; (chart-draw-key c) - (message "Rendering chart...done") - )) - -(defmethod chart-draw-title ((c chart)) + (with-silent-modifications + (save-excursion + (if buff (set-buffer buff)) + (erase-buffer) + (insert (make-string (window-height (selected-window)) ?\n)) + ;; Start by displaying the axis + (chart-draw-axis c) + ;; Display title + (chart-draw-title c) + ;; Display data + (message "Rendering chart...") + (sit-for 0) + (chart-draw-data c) + ;; Display key + ; (chart-draw-key c) + (message "Rendering chart...done") + ))) + +(cl-defmethod chart-draw-title ((c chart)) "Draw a title upon the chart. Argument C is the chart object." (chart-display-label (oref c title) 'horizontal 0 0 (window-width) (oref c title-face))) -(defmethod chart-size-in-dir ((c chart) dir) +(cl-defmethod chart-size-in-dir ((c chart) dir) "Return the physical size of chart C in direction DIR." (if (eq dir 'vertical) (oref c y-width) (oref c x-width))) -(defmethod chart-draw-axis ((c chart)) +(cl-defmethod chart-draw-axis ((c chart)) "Draw axis into the current buffer defined by chart C." (let ((ymarg (oref c y-margin)) (xmarg (oref c x-margin)) @@ -247,7 +250,7 @@ Argument C is the chart object." ymarg (+ ymarg xlen))) ) -(defmethod chart-axis-draw ((a chart-axis) &optional dir margin zone start end) +(cl-defmethod chart-axis-draw ((a chart-axis) &optional dir margin zone start end) "Draw some axis for A in direction DIR with MARGIN in boundary. ZONE is a zone specification. START and END represent the boundary." @@ -257,7 +260,7 @@ START and END represent the boundary." 1 0)) start end (oref a name-face))) -(defmethod chart-translate-xpos ((c chart) x) +(cl-defmethod chart-translate-xpos ((c chart) x) "Translate in chart C the coordinate X into a screen column." (let ((range (oref (oref c x-axis) bounds))) (+ (oref c x-margin) @@ -266,7 +269,7 @@ START and END represent the boundary." (float (- (cdr range) (car range)))))))) ) -(defmethod chart-translate-ypos ((c chart) y) +(cl-defmethod chart-translate-ypos ((c chart) y) "Translate in chart C the coordinate Y into a screen row." (let ((range (oref (oref c y-axis) bounds))) (+ (oref c x-margin) @@ -276,7 +279,7 @@ START and END represent the boundary." (float (- (cdr range) (car range))))))))) ) -(defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone _start _end) +(cl-defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone _start _end) "Draw axis information based upon a range to be spread along the edge. A is the chart to draw. DIR is the direction. MARGIN, ZONE, START, and END specify restrictions in chart space." @@ -313,7 +316,7 @@ MARGIN, ZONE, START, and END specify restrictions in chart space." (setq i (+ i j)))) ) -(defmethod chart-translate-namezone ((c chart) n) +(cl-defmethod chart-translate-namezone ((c chart) n) "Return a dot-pair representing a positional range for a name. The name in chart C of the Nth name resides. Automatically compensates for direction." @@ -329,7 +332,7 @@ Automatically compensates for direction." (+ m -1 (round (* lpn (+ 1.0 (float n)))))) )) -(defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone _start _end) +(cl-defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone _start _end) "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." @@ -368,7 +371,7 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing s (cdr s)))) ) -(defmethod chart-draw-data ((c chart-bar)) +(cl-defmethod chart-draw-data ((c chart-bar)) "Display the data available in a bar chart C." (let* ((data (oref c sequences)) (dir (oref c direction)) @@ -413,7 +416,7 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing (setq data (cdr data)))) ) -(defmethod chart-add-sequence ((c chart) &optional seq axis-label) +(cl-defmethod chart-add-sequence ((c chart) &optional seq axis-label) "Add to chart object C the sequence object SEQ. If AXIS-LABEL, then the axis stored in C is updated with the bounds of SEQ, or is created with the bounds of SEQ." @@ -433,11 +436,10 @@ or is created with the bounds of SEQ." (setq axis (make-instance 'chart-axis-range :name (oref seq name) :chart c))) - (while l - (if (< (car l) (car range)) (setcar range (car l))) - (if (> (car l) (cdr range)) (setcdr range (car l))) - (setq l (cdr l))) - (oset axis bounds range))) + (dolist (x l) + (if (< x (car range)) (setcar range x)) + (if (> x (cdr range)) (setcdr range x))) + (oset axis bounds range))) (if (eq axis-label 'x-axis) (oset axis loweredge nil)) (eieio-oset c axis-label axis) )) @@ -445,17 +447,16 @@ or is created with the bounds of SEQ." ;;; Charting optimizers -(defmethod chart-trim ((c chart) max) +(cl-defmethod chart-trim ((c chart) max) "Trim all sequences in chart C to be at most MAX elements long." (let ((s (oref c sequences))) - (while s - (let ((sl (oref (car s) data))) + (dolist (x s) + (let ((sl (oref x data))) (if (> (length sl) max) - (setcdr (nthcdr (1- max) sl) nil))) - (setq s (cdr s)))) + (setcdr (nthcdr (1- max) sl) nil))))) ) -(defmethod chart-sort ((c chart) pred) +(cl-defmethod chart-sort ((c chart) pred) "Sort the data in chart C using predicate PRED. See `chart-sort-matchlist' for more details." (let* ((sl (oref c sequences)) @@ -479,7 +480,7 @@ See `chart-sort-matchlist' for more details." (defun chart-sort-matchlist (namelst numlst pred) "Sort NAMELST and NUMLST (both sequence objects) based on predicate PRED. -PRED should be the equivalent of '<, except it must expect two +PRED should be the equivalent of `<', except it must expect two cons cells of the form (NAME . NUM). See `sort' for more details." ;; 1 - create 1 list of cons cells (let ((newlist nil) @@ -571,7 +572,7 @@ R1 and R2 are dotted pairs. Colorize it with FACE." (defun chart-bar-quickie (dir title namelst nametitle numlst numtitle &optional max sort-pred) "Wash over the complex EIEIO stuff and create a nice bar chart. -Create it going in direction DIR ['horizontal 'vertical] with TITLE +Create it going in direction DIR [`horizontal' `vertical'] with TITLE using a name sequence NAMELST labeled NAMETITLE with values NUMLST labeled NUMTITLE. Optional arguments: @@ -613,27 +614,20 @@ SORT-PRED if desired." (defun chart-file-count (dir) "Draw a chart displaying the number of different file extensions in DIR." (interactive "DDirectory: ") - (if (not (string-match "/$" dir)) - (setq dir (concat dir "/"))) (message "Collecting statistics...") (let ((flst (directory-files dir nil nil t)) (extlst (list "<dir>")) (cntlst (list 0))) - (while flst - (let* ((j (string-match "[^\\.]\\(\\.[a-zA-Z]+\\|~\\|#\\)$" (car flst))) - (s (if (file-accessible-directory-p (concat dir (car flst))) - "<dir>" - (if j - (substring (car flst) (match-beginning 1) (match-end 1)) - nil))) + (dolist (f flst) + (let* ((x (file-name-extension f)) + (s (if (file-accessible-directory-p (expand-file-name f dir)) + "<dir>" x)) (m (member s extlst))) - (if (not s) nil + (unless (null s) (if m - (let ((cell (nthcdr (- (length extlst) (length m)) cntlst))) - (setcar cell (1+ (car cell)))) + (cl-incf (car (nthcdr (- (length extlst) (length m)) cntlst))) (setq extlst (cons s extlst) - cntlst (cons 1 cntlst))))) - (setq flst (cdr flst))) + cntlst (cons 1 cntlst)))))) ;; Let's create the chart! (chart-bar-quickie 'vertical "Files Extension Distribution" extlst "File Extensions" diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 536e4186c41..e1e756be077 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,6 +1,6 @@ ;;; check-declare.el --- Check declare-function statements -;; Copyright (C) 2007-2015 Free Software Foundation, Inc. +;; Copyright (C) 2007-2016 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint @@ -43,7 +43,7 @@ "Name of buffer used to display any `check-declare' warnings.") (defun check-declare-locate (file basefile) - "Return the full path of FILE. + "Return the relative name of FILE. Expands files with a \".c\" or \".m\" extension relative to the Emacs \"src/\" directory. Otherwise, `locate-library' searches for FILE. If that fails, expands FILE relative to BASEFILE's directory part. @@ -70,6 +70,7 @@ the result." (string-match "\\.el\\'" tfile)) tfile (concat tfile ".el"))))) + (setq file (file-relative-name file)) (if ext (concat "ext:" file) file))) @@ -80,49 +81,40 @@ where only the first two elements need be present. This claims that FNFILE defines FN, with ARGLIST. FILEONLY non-nil means only check that FNFILE exists, not that it defines FN. This is for function definitions that we don't know how to recognize (e.g. some macros)." - (let ((m (format "Scanning %s..." file)) - alist form len fn fnfile arglist fileonly) - (message "%s" m) + (let (alist) (with-temp-buffer (insert-file-contents file) ;; FIXME we could theoretically be inside a string. (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) - (goto-char (match-beginning 1)) - (if (and (setq form (ignore-errors (read (current-buffer)))) + (let ((pos (match-beginning 1))) + (goto-char pos) + (let ((form (ignore-errors (read (current-buffer)))) + len fn formfile fnfile arglist fileonly) + (if (and ;; Exclude element of byte-compile-initial-macro-environment. (or (listp (cdr form)) (setq form nil)) (> (setq len (length form)) 2) (< len 6) + (setq formfile (nth 2 form)) (symbolp (setq fn (cadr form))) (setq fn (symbol-name fn)) ; later we use as a search string - (stringp (setq fnfile (nth 2 form))) - (setq fnfile (check-declare-locate fnfile - (expand-file-name file))) + (stringp formfile) + (setq fnfile (check-declare-locate formfile file)) ;; Use t to distinguish unspecified arglist from empty one. (or (eq t (setq arglist (if (> len 3) (nth 3 form) t))) (listp arglist)) (symbolp (setq fileonly (nth 4 form)))) - (setq alist (cons (list fnfile fn arglist fileonly) alist)) - ;; FIXME make this more noticeable. - (if form (message "Malformed declaration for `%s'" (cadr form)))))) - (message "%sdone" m) + (setq alist (cons (list fnfile fn arglist fileonly) alist)) + (when form + (check-declare-warn file (or fn "unknown function") + (if (stringp formfile) formfile + "unknown file") + "Malformed declaration" + (line-number-at-pos pos)))))))) alist)) -(defun check-declare-errmsg (errlist &optional full) - "Return a string with the number of errors in ERRLIST, if any. -Normally just counts the number of elements in ERRLIST. -With optional argument FULL, sums the number of elements in each element." - (if errlist - (let ((l (length errlist))) - (when full - (setq l 0) - (dolist (e errlist) - (setq l (+ l (1- (length e)))))) - (format "%d problem%s found" l (if (= l 1) "" "s"))) - "OK")) - (autoload 'byte-compile-arglist-signature "bytecomp") (defgroup check-declare nil @@ -131,6 +123,7 @@ With optional argument FULL, sums the number of elements in each element." (defcustom check-declare-ext-errors nil "When non-nil, warn about functions not found in :ext." + :version "25.1" :type 'boolean) (defun check-declare-verify (fnfile fnlist) @@ -143,11 +136,9 @@ to only check that FNFILE exists, not that it actually defines FN. Returns nil if all claims are found to be true, otherwise a list of errors with elements of the form \(FILE FN TYPE), where TYPE is a string giving details of the error." - (let ((m (format "Checking %s..." fnfile)) - (cflag (member (file-name-extension fnfile) '("c" "m"))) + (let ((cflag (member (file-name-extension fnfile) '("c" "m"))) (ext (string-match "^ext:" fnfile)) re fn sig siglist arglist type errlist minargs maxargs) - (message "%s" m) (if ext (setq fnfile (substring fnfile 4))) (if (file-regular-p fnfile) @@ -215,7 +206,8 @@ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) (setq arglist (nth 2 e) type (if (not re) - "file not found" + (when (or check-declare-ext-errors (not ext)) + "file not found") (if (not (setq sig (assoc (cadr e) siglist))) (unless (nth 3 e) ; fileonly "function not found") @@ -234,13 +226,6 @@ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) "arglist mismatch"))))) (when type (setq errlist (cons (list (car e) (cadr e) type) errlist)))) - (message "%s%s" m - (if (or re (or check-declare-ext-errors - (not ext))) - (check-declare-errmsg errlist) - (progn - (setq errlist nil) - "skipping external file"))) errlist)) (defun check-declare-sort (alist) @@ -257,30 +242,27 @@ Returned list has elements FNFILE (FILE ...)." (setq sort (cons (list fnfile (cons file rest)) sort))))) sort)) -(defun check-declare-warn (file fn fnfile type) +(defun check-declare-warn (file fn fnfile type &optional line) "Warn that FILE made a false claim about FN in FNFILE. -TYPE is a string giving the nature of the error. Warning is displayed in -`check-declare-warning-buffer'." +TYPE is a string giving the nature of the error. +Optional LINE is the claim's line number; otherwise, search for the claim. +Display warning in `check-declare-warning-buffer'." (let ((warning-prefix-function (lambda (level entry) - (let ((line 0) - (col 0)) - (insert - (with-current-buffer (find-file-noselect file) - (goto-char (point-min)) - (when (re-search-forward - (format "(declare-function[ \t\n]+%s" fn) nil t) - (goto-char (match-beginning 0)) - (setq line (line-number-at-pos)) - (setq col (1+ (current-column)))) - (format "%s:%d:%d:" - (file-name-nondirectory file) - line col)))) + (insert (format "%s:%d:" (file-relative-name file) (or line 0))) entry)) (warning-fill-prefix " ")) + (unless line + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (when (and (not line) + (re-search-forward + (format "(declare-function[ \t\n]+%s" fn) nil t)) + (goto-char (match-beginning 0)) + (setq line (line-number-at-pos))))) (display-warning 'check-declare (format-message "said `%s' was defined in %s: %s" - fn (file-name-nondirectory fnfile) type) + fn (file-relative-name fnfile) type) nil check-declare-warning-buffer))) (declare-function compilation-forget-errors "compile" ()) @@ -288,7 +270,18 @@ TYPE is a string giving the nature of the error. Warning is displayed in (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. Return a list of any errors found." - (let (alist err errlist) + (if (get-buffer check-declare-warning-buffer) + (kill-buffer check-declare-warning-buffer)) + (let ((buf (get-buffer-create check-declare-warning-buffer)) + alist err errlist) + (with-current-buffer buf + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + (setq mode-line-process + '(:propertize ":run" face compilation-mode-line-run)) + (let ((inhibit-read-only t)) + (insert "\f\n")) + (compilation-forget-errors)) (dolist (file files) (setq alist (cons (cons file (check-declare-scan file)) alist))) ;; Sort so that things are ordered by the files supposed to @@ -297,19 +290,15 @@ Return a list of any errors found." (if (setq err (check-declare-verify (car e) (cdr e))) (setq errlist (cons (cons (car e) err) errlist)))) (setq errlist (nreverse errlist)) - (if (get-buffer check-declare-warning-buffer) - (kill-buffer check-declare-warning-buffer)) - (with-current-buffer (get-buffer-create check-declare-warning-buffer) - (unless (derived-mode-p 'compilation-mode) - (compilation-mode)) - (let ((inhibit-read-only t)) - (insert "\f\n")) - (compilation-forget-errors)) ;; Sort back again so that errors are ordered by the files ;; containing the declare-function statements. (dolist (e (check-declare-sort errlist)) (dolist (f (cdr e)) (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + (with-current-buffer buf + (setq mode-line-process + '(:propertize ":exit" face compilation-mode-line-run)) + (force-mode-line-update)) errlist)) ;;;###autoload @@ -319,34 +308,22 @@ See `check-declare-directory' for more information." (interactive "fFile to check: ") (or (file-exists-p file) (error "File `%s' not found" file)) - (let ((m (format "Checking %s..." file)) - errlist) - (message "%s" m) - (setq errlist (check-declare-files file)) - (message "%s%s" m (check-declare-errmsg errlist)) - errlist)) + (check-declare-files file)) ;;;###autoload (defun check-declare-directory (root) "Check veracity of all `declare-function' statements under directory ROOT. Returns non-nil if any false statements are found." (interactive "DDirectory to check: ") - (or (file-directory-p (setq root (expand-file-name root))) + (setq root (directory-file-name (file-relative-name root))) + (or (file-directory-p root) (error "Directory `%s' not found" root)) - (let ((m "Checking `declare-function' statements...") - (m2 "Finding files with declarations...") - errlist files) - (message "%s" m) - (message "%s" m2) - (setq files (process-lines find-program root - "-name" "*.el" - "-exec" grep-program - "-l" "^[ \t]*(declare-function" "{}" ";")) - (message "%s%d found" m2 (length files)) + (let ((files (process-lines find-program root + "-name" "*.el" + "-exec" grep-program + "-l" "^[ \t]*(declare-function" "{}" "+"))) (when files - (setq errlist (apply 'check-declare-files files)) - (message "%s%s" m (check-declare-errmsg errlist t)) - errlist))) + (apply #'check-declare-files files)))) (provide 'check-declare) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index bf1a21acaf1..769c2fe5741 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,6 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -*- lexical-binding:t -*- -;; Copyright (C) 1997-1998, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2016 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -270,6 +270,7 @@ made in the style guide relating to order." (defcustom checkdoc-package-keywords-flag nil "Non-nil means warn if this file's package keywords are not recognized. Currently, all recognized keywords must be on `finder-known-keywords'." + :version "25.1" :type 'boolean) (define-obsolete-variable-alias 'checkdoc-style-hooks @@ -1061,7 +1062,7 @@ Calls `checkdoc' with spell-checking turned on. Prefix argument is the same as for `checkdoc'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc nil current-prefix-arg))) + (call-interactively #'checkdoc))) ;;;###autoload (defun checkdoc-ispell-current-buffer () @@ -1070,7 +1071,7 @@ Calls `checkdoc-current-buffer' with spell-checking turned on. Prefix argument is the same as for `checkdoc-current-buffer'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-current-buffer nil current-prefix-arg))) + (call-interactively #'checkdoc-current-buffer))) ;;;###autoload (defun checkdoc-ispell-interactive () @@ -1079,7 +1080,7 @@ Calls `checkdoc-interactive' with spell-checking turned on. Prefix argument is the same as for `checkdoc-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-interactive))) ;;;###autoload (defun checkdoc-ispell-message-interactive () @@ -1098,7 +1099,7 @@ Calls `checkdoc-message-text' with spell-checking turned on. Prefix argument is the same as for `checkdoc-message-text'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-message-text nil current-prefix-arg))) + (call-interactively #'checkdoc-message-text))) ;;;###autoload (defun checkdoc-ispell-start () @@ -1107,7 +1108,7 @@ Calls `checkdoc-start' with spell-checking turned on. Prefix argument is the same as for `checkdoc-start'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-start nil current-prefix-arg))) + (call-interactively #'checkdoc-start))) ;;;###autoload (defun checkdoc-ispell-continue () @@ -1116,7 +1117,7 @@ Calls `checkdoc-continue' with spell-checking turned on. Prefix argument is the same as for `checkdoc-continue'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-continue nil current-prefix-arg))) + (call-interactively #'checkdoc-continue))) ;;;###autoload (defun checkdoc-ispell-comments () @@ -1125,7 +1126,7 @@ Calls `checkdoc-comments' with spell-checking turned on. Prefix argument is the same as for `checkdoc-comments'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-comments nil current-prefix-arg))) + (call-interactively #'checkdoc-comments))) ;;;###autoload (defun checkdoc-ispell-defun () @@ -1134,7 +1135,7 @@ Calls `checkdoc-defun' with spell-checking turned on. Prefix argument is the same as for `checkdoc-defun'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively #'checkdoc-defun nil current-prefix-arg))) + (call-interactively #'checkdoc-defun))) ;;; Error Management ;; @@ -1579,7 +1580,7 @@ mouse-[0-3]\\)\\)\\>")) (if (and sym (boundp sym) (fboundp sym) (save-excursion (goto-char mb) - (forward-word -1) + (forward-word-strictly -1) (not (looking-at "variable\\|option\\|function\\|command\\|symbol")))) (if (checkdoc-autofix-ask-replace @@ -1595,7 +1596,7 @@ mouse-[0-3]\\)\\)\\>")) nil t nil nil "variable"))) (goto-char (1- mb)) (insert disambiguate " ") - (forward-word 1)) + (forward-word-strictly 1)) (setq ret (format "Disambiguate %s by preceding w/ \ function,command,variable,option or symbol." ms1)))))) @@ -1637,6 +1638,17 @@ function,command,variable,option or symbol." ms1)))))) ;; * If a user option variable records a true-or-false ;; condition, give it a name that ends in `-flag'. + ;; "True ..." should be "Non-nil ..." + (when (looking-at "\"\\*?\\(True\\)\\b") + (if (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Say \"Non-nil\" instead of \"True\"? " + "Non-nil") + nil + (checkdoc-create-error + "\"True\" should usually be \"Non-nil\"" + (match-beginning 1) (match-end 1)))) + ;; If the variable has -flag in the name, make sure (if (and (string-match "-flag$" (car fp)) (not (looking-at "\"\\*?Non-nil\\s-+means\\s-+"))) @@ -1797,6 +1809,16 @@ Replace with \"%s\"? " original replace) "Probably \"%s\" should be imperative \"%s\"" original replace) (match-beginning 1) (match-end 1)))))) + ;; "Return true ..." should be "Return non-nil ..." + (when (looking-at "\"Return \\(true\\)\\b") + (if (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Say \"non-nil\" instead of \"true\"? " + "non-nil") + nil + (checkdoc-create-error + "\"true\" should usually be \"non-nil\"" + (match-beginning 1) (match-end 1)))) ;; Done with functions ))) ;;* When a documentation string refers to a Lisp symbol, write it as diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index afa021dffc7..0033a94fb5c 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,6 +1,6 @@ ;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2016 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions @@ -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) @@ -822,7 +824,7 @@ including `cl-block' and `cl-eval-when'." (cl--describe-class-slots class) ;; Describe all the methods specific to this class. - (let ((generics (cl--generic-all-functions type))) + (let ((generics (cl-generic-all-functions type))) (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) (dolist (generic generics) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index aae517e8ea7..61186e1a881 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1,6 +1,6 @@ ;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*- -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Version: 1.0 @@ -83,11 +83,14 @@ ;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods ;; to cl-generic-combine-methods with a specializer that says it applies only ;; when some particular qualifier is used). -;; - A way to dispatch on the context (e.g. the major-mode, some global -;; variable, you name it). ;;; Code: +;; The autoloads.el mechanism which adds package--builtin-versions +;; maintenance to loaddefs.el doesn't work for preloaded packages (such +;; as this one), so we have to do it by hand! +(push (purecopy '(cl-generic 1 0)) package--builtin-versions) + ;; Note: For generic functions that dispatch on several arguments (i.e. those ;; which use the multiple-dispatch feature), we always use the same "tagcodes" ;; and the same set of arguments on which to dispatch. This works, but is @@ -195,9 +198,9 @@ OPTIONS-AND-METHODS currently understands: - (declare DECLARATIONS) - (:argument-precedence-order &rest ARGS) - (:method [QUALIFIERS...] ARGS &rest BODY) -BODY, if present, is used as the body of a default method. +DEFAULT-BODY, if present, is used as the body of a default method. -\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)" +\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3)) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) @@ -268,7 +271,7 @@ This macro can only be used within the lexical scope of a cl-generic method." (defmacro cl-generic-define-context-rewriter (name args &rest body) "Define a special kind of context named NAME. -Whenever a context specializer of the form (NAME . ACTUALS) appears, +Whenever a context specializer of the form (NAME . ARGS) appears, the specializer used will be the one returned by BODY." (declare (debug (&define name lambda-list def-body)) (indent defun)) `(eval-and-compile @@ -355,15 +358,35 @@ 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) "Define a new method for generic function NAME. I.e. it defines the implementation of NAME to use for invocations where the -value of the dispatch argument matches the specified TYPE. -The dispatch argument has to be one of the mandatory arguments, and -all methods of NAME have to use the same argument for dispatch. -The dispatch argument and TYPE are specified in ARGS where the corresponding +values of the dispatch arguments match the specified TYPEs. +The dispatch arguments have to be among the mandatory arguments, and +all methods of NAME have to use the same set of arguments for dispatch. +Each dispatch argument and TYPE are specified in ARGS where the corresponding formal argument appears as (VAR TYPE) rather than just VAR. The optional second argument QUALIFIER is a specifier that @@ -372,9 +395,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'. + +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 a type, TYPE can also be of the form `(eql VAL)' in -which case this method will be invoked when the argument is `eql' to VAL. +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) @@ -406,7 +437,8 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. - (declare-function ,name "") + ;; The ",'" is a no-op that pacifies check-declare. + (,'declare-function ,name "") (cl-generic-define-method ',name ',(nreverse qualifiers) ',args ,uses-cnm ,fun))))) @@ -419,6 +451,12 @@ which case this method will be invoked when the argument is `eql' to VAL. (setq methods (cdr methods))) methods) +(defun cl--generic-load-hist-format (name qualifiers specializers) + ;; FIXME: This function is used in elisp-mode.el and + ;; elisp-mode-tests.el, but I still decided to use an internal name + ;; because these uses should be removed or moved into cl-generic.el. + `(,name ,qualifiers . ,specializers)) + ;;;###autoload (defun cl-generic-define-method (name qualifiers args uses-cnm function) (pcase-let* @@ -459,7 +497,9 @@ which case this method will be invoked when the argument is `eql' to VAL. (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-load-hist-format + (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)? @@ -662,6 +702,15 @@ FUN is the function that should be called when METHOD calls (setq fun (cl-generic-call-method generic method fun))) fun))))) +(defun cl-generic-apply (generic args) + "Like `apply' but takes a cl-generic object rather than a function." + ;; Handy in cl-no-applicable-method, for example. + ;; In Common Lisp, generic-function objects are funcallable. Ideally + ;; we'd want the same in Elisp, but it would either require using a very + ;; different (and less efficient) representation of cl--generic objects, + ;; or non-trivial changes in the general infrastructure (compiler and such). + (apply (cl--generic-name generic) args)) + (defun cl--generic-arg-specializer (method dispatch-arg) (or (if (integerp dispatch-arg) (nth dispatch-arg @@ -732,7 +781,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))) @@ -797,10 +846,10 @@ methods.") ;;; Define some pre-defined generic functions, used internally. -(define-error 'cl-no-method "No method for %S") -(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method) -(define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method) -(define-error 'cl-no-applicable-method "No applicable method for %S" +(define-error 'cl-no-method "No method") +(define-error 'cl-no-next-method "No next method" 'cl-no-method) +(define-error 'cl-no-primary-method "No primary method" 'cl-no-method) +(define-error 'cl-no-applicable-method "No applicable method" 'cl-no-method) (cl-defgeneric cl-no-next-method (generic method &rest args) @@ -836,18 +885,22 @@ Can only be used from within the lexical body of a primary or around method." (defun cl--generic-search-method (met-name) "For `find-function-regexp-alist'. Searches for a cl-defmethod. -MET-NAME is a cons (SYMBOL . SPECIALIZERS)." +MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" (regexp-quote (format "%s" (car met-name))) "\\_>"))) (or (re-search-forward (concat base-re "[^&\"\n]*" + (mapconcat (lambda (qualifier) + (regexp-quote (format "%S" qualifier))) + (cadr met-name) + "[ \t\n]*") (mapconcat (lambda (specializer) (regexp-quote (format "%S" (if (consp specializer) (nth 1 specializer) specializer)))) - (remq t (cdr met-name)) + (remq t (cddr met-name)) "[ \t\n]*)[^&\"\n]*")) nil t) (re-search-forward base-re nil t)))) @@ -904,8 +957,10 @@ 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 (cl--generic-load-hist-format + 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 `")) @@ -933,7 +988,7 @@ MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (setq applies t))) applies)) -(defun cl--generic-all-functions (&optional type) +(defun cl-generic-all-functions (&optional type) "Return a list of all generic functions. Optional TYPE argument returns only those functions that contain methods for TYPE." @@ -989,7 +1044,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)) @@ -1009,12 +1065,17 @@ 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)) (cl--generic-prefill-dispatchers 0 (eql nil)) (cl--generic-prefill-dispatchers window-system (eql nil)) +(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--get-selection) + (eql nil)) +(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection) + (eql nil)) ;;; Support for cl-defstructs specializers. @@ -1060,7 +1121,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 @@ -1104,7 +1165,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 @@ -1142,7 +1204,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-indent.el b/lisp/emacs-lisp/cl-indent.el index 5134e50fa3b..4f1100c283f 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,6 +1,6 @@ ;;; cl-indent.el --- enhanced lisp-indent mode -;; Copyright (C) 1987, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1987, 2000-2016 Free Software Foundation, Inc. ;; Author: Richard Mlynarik <mly@eddie.mit.edu> ;; Created: July 1987 diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 2dd05192019..b4017140f3c 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -1,6 +1,6 @@ ;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2016 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 1.0 @@ -660,10 +660,12 @@ If ALIST is non-nil, the new pairs are prepended to it." (gv-define-setter face-underline-p (x f &optional s) `(set-face-underline ,f ,x ,s)) (gv-define-simple-setter file-modes set-file-modes t) -(gv-define-simple-setter frame-height set-screen-height t) +(gv-define-setter frame-height (x &optional frame) + `(set-frame-height (or ,frame (selected-frame)) ,x)) (gv-define-simple-setter frame-parameters modify-frame-parameters t) (gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) -(gv-define-simple-setter frame-width set-screen-width t) +(gv-define-setter frame-width (x &optional frame) + `(set-frame-width (or ,frame (selected-frame)) ,x)) (gv-define-simple-setter getenv setenv t) (gv-define-simple-setter get-register set-register) (gv-define-simple-setter global-key-binding global-set-key) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c42094f0f0c..210a2083727 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,6 +1,6 @@ ;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2016 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Old-Version: 2.02 @@ -298,9 +298,11 @@ FORM is of the form (ARGS . BODY)." (if (stringp (car header)) (pop header)) ;; Be careful with make-symbol and (back)quote, ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))) header))) ;; FIXME: we'd want to choose an arg name for the &rest param ;; and pass that as `expr' to cl--do-arglist, but that ends up @@ -325,6 +327,20 @@ FORM is of the form (ARGS . BODY)." Like normal `defun', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (cl-block NAME ...). +The full form of a Common Lisp function argument list is + + (VAR... + [&optional (VAR [INITFORM [SVAR]])...] + [&rest|&body VAR] + [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]] + [&aux (VAR [INITFORM])...]) + +VAR maybe be replaced recursively with an argument list for +destructing, `&whole' is supported within these sublists. If +SVAR, INITFORM, and KEYWORD are all omitted, then `(VAR)' may be +written simply `VAR'. See the Info node `(cl)Argument Lists' for +more details. + \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. @@ -404,6 +420,21 @@ and BODY is implicitly surrounded by (cl-block NAME ...). Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (cl-block NAME ...). +The full form of a Common Lisp macro argument list is + + (VAR... + [&optional (VAR [INITFORM [SVAR]])...] + [&rest|&body VAR] + [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]] + [&aux (VAR [INITFORM])...] + [&environment VAR]) + +VAR maybe be replaced recursively with an argument list for +destructing, `&whole' is supported within these sublists. If +SVAR, INITFORM, and KEYWORD are all omitted, then `(VAR)' may be +written simply `VAR'. See the Info node `(cl)Argument Lists' for +more details. + \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug (&define name cl-macro-list cl-declarations-or-string def-body)) @@ -849,9 +880,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)] @@ -892,6 +923,7 @@ For more details, see Info node `(cl)Loop Facility'. "count" "maximize" "minimize" "if" "unless" "return"] form] + ["using" (symbolp symbolp)] ;; Simple default, which covers 99% of the cases. symbolp form))) (if (not (memq t (mapcar #'symbolp @@ -1806,6 +1838,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. @@ -2082,7 +2135,7 @@ Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" - (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) + (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) (cond ((cdr bindings) `(cl-symbol-macrolet (,(car bindings)) @@ -2526,20 +2579,19 @@ non-nil value, that slot cannot be set via `setf'. [&or symbolp (gate symbolp &rest - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp] ;; Not finished. - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] + [&or symbolp + (&or [":conc-name" symbolp] + [":constructor" symbolp &optional cl-lambda-list] + [":copier" symbolp] + [":predicate" symbolp] + [":include" symbolp &rest sexp] ;; Not finished. + [":print-function" sexp] + [":type" symbolp] + [":named"] + [":initial-offset" natnump])])] [&optional stringp] ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form - &optional ":read-only" sexp)))) + &rest &or symbolp (symbolp &optional def-form &rest sexp)))) (let* ((name (if (consp struct) (car struct) struct)) (opts (cdr-safe struct)) (slots nil) @@ -2603,7 +2655,7 @@ non-nil value, that slot cannot be set via `setf'. (setq descs (nconc (make-list (car args) '(cl-skip-slot)) descs))) (t - (error "Slot option %s unrecognized" opt))))) + (error "Structure option %s unrecognized" opt))))) (unless (or include-name type) (setq include-name cl--struct-default-parent)) (when include-name (setq include (cl--struct-get-class include-name))) @@ -2659,7 +2711,7 @@ non-nil value, that slot cannot be set via `setf'. (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) - (slot (car desc))) + (slot (pop desc))) (if (memq slot '(cl-tag-slot cl-skip-slot)) (progn (push nil slots) @@ -2669,8 +2721,12 @@ non-nil value, that slot cannot be set via `setf'. (error "Duplicate slots named %s in %s" slot name)) (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) - (push (nth 1 desc) defaults) + (push (pop desc) defaults) + ;; The arg "cl-x" is referenced by name in eg pred-form + ;; and pred-check, so changing it is not straightforward. (push `(cl-defsubst ,accessor (cl-x) + ,(format "Access slot \"%s\" of `%s' struct CL-X." + slot struct) (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check @@ -2680,7 +2736,9 @@ non-nil value, that slot cannot be set via `setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) - (if (cadr (memq :read-only (cddr desc))) + (when (cl-oddp (length desc)) + (error "Invalid options for slot %s in %s" slot name)) + (if (plist-get desc ':read-only) (push `(gv-define-expander ,accessor (lambda (_cl-do _cl-x) (error "%s is a read-only slot" ',accessor))) @@ -2730,7 +2788,7 @@ non-nil value, that slot cannot be set via `setf'. slots defaults))) (push `(cl-defsubst ,cname (&cl-defs (nil ,@descs) ,@args) - ,(if (stringp doc) (list doc) + ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) @@ -2829,8 +2887,8 @@ is a shorthand for (NAME NAME)." (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. -STRUCT-TYPE is a symbol naming a struct type. Return 'vector or -'list, or nil if STRUCT-TYPE is not a struct type. " +STRUCT-TYPE is a symbol naming a struct type. Return `vector' or +`list', or nil if STRUCT-TYPE is not a struct type. " (declare (side-effect-free t) (pure t)) (cl--struct-class-type (cl--struct-get-class struct-type))) @@ -2884,7 +2942,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (put 'real 'cl-deftype-satisfies #'numberp) (put 'fixnum 'cl-deftype-satisfies #'integerp) (put 'base-char 'cl-deftype-satisfies #'characterp) -(put 'character 'cl-deftype-satisfies #'integerp) +(put 'character 'cl-deftype-satisfies #'natnump) ;;;###autoload @@ -2972,7 +3030,7 @@ omitted, a default message listing FORM itself is used." (delq nil (mapcar (lambda (x) (unless (macroexp-const-p x) x)) - (cdr form)))))) + (cdr-safe form)))))) `(progn (or ,form (cl--assertion-failed diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 03480b2756b..2b022c49053 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -1,8 +1,9 @@ ;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*- -;; Copyright (C) 2015 Free Software Foundation, Inc +;; Copyright (C) 2015-2016 Free Software Foundation, Inc ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Package: emacs ;; This file is part of GNU Emacs. @@ -44,7 +45,7 @@ (defun cl--assertion-failed (form &optional string sargs args) (if debug-on-error - (debug `(cl-assertion-failed ,form ,string ,@sargs)) + (funcall debugger `(cl-assertion-failed ,form ,string ,@sargs)) (if string (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 3aea67ad11b..3f8b1eec66e 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,6 +1,6 @@ ;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*- -;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2016 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Old-Version: 2.02 @@ -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))) @@ -134,24 +144,24 @@ cl-accum))) ;;;###autoload -(defun cl-fill (seq item &rest cl-keys) +(defun cl-fill (cl-seq cl-item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" (cl--parsing-keywords ((:start 0) :end) () - (if (listp seq) - (let ((p (nthcdr cl-start seq)) - (n (if cl-end (- cl-end cl-start) 8000000))) - (while (and p (>= (setq n (1- n)) 0)) - (setcar p item) + (if (listp cl-seq) + (let ((p (nthcdr cl-start cl-seq)) + (n (and cl-end (- cl-end cl-start)))) + (while (and p (or (null n) (>= (cl-decf n) 0))) + (setcar p cl-item) (setq p (cdr p)))) - (or cl-end (setq cl-end (length seq))) - (if (and (= cl-start 0) (= cl-end (length seq))) - (fillarray seq item) + (or cl-end (setq cl-end (length cl-seq))) + (if (and (= cl-start 0) (= cl-end (length cl-seq))) + (fillarray cl-seq cl-item) (while (< cl-start cl-end) - (aset seq cl-start item) + (aset cl-seq cl-start cl-item) (setq cl-start (1+ cl-start))))) - seq)) + cl-seq)) ;;;###autoload (defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys) @@ -170,16 +180,20 @@ SEQ1 is destructively modified, then returned. (elt cl-seq2 (+ cl-start2 cl-n)))))) (if (listp cl-seq1) (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) - (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) + (cl-n1 (and cl-end1 (- cl-end1 cl-start1)))) (if (listp cl-seq2) (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) - (cl-n (min cl-n1 - (if cl-end2 (- cl-end2 cl-start2) 4000000)))) - (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) + (cl-n (cond ((and cl-n1 cl-end2) + (min cl-n1 (- cl-end2 cl-start2))) + ((and cl-n1 (null cl-end2)) cl-n1) + ((and (null cl-n1) cl-end2) (- cl-end2 cl-start2))))) + (while (and cl-p1 cl-p2 (or (null cl-n) (>= (cl-decf cl-n) 0))) (setcar cl-p1 (car cl-p2)) (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) - (setq cl-end2 (min (or cl-end2 (length cl-seq2)) - (+ cl-start2 cl-n1))) + (setq cl-end2 (if (null cl-n1) + (or cl-end2 (length cl-seq2)) + (min (or cl-end2 (length cl-seq2)) + (+ cl-start2 cl-n1)))) (while (and cl-p1 (< cl-start2 cl-end2)) (setcar cl-p1 (aref cl-seq2 cl-start2)) (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) @@ -205,9 +219,10 @@ to avoid corrupting the original SEQ. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) + (let ((len (length cl-seq))) + (if (<= (or cl-count (setq cl-count len)) 0) cl-seq - (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) + (if (or (nlistp cl-seq) (and cl-from-end (< cl-count (/ len 2)))) (let ((cl-i (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) (if cl-i @@ -219,7 +234,7 @@ to avoid corrupting the original SEQ. (if (listp cl-seq) cl-res (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) cl-seq)) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (if (= cl-start 0) (while (and cl-seq (> cl-end 0) (cl--check-test cl-item (car cl-seq)) @@ -240,7 +255,7 @@ to avoid corrupting the original SEQ. :start 0 :end (1- cl-end) :count (1- cl-count) cl-keys)))) cl-seq)) - cl-seq))))) + cl-seq)))))) ;;;###autoload (defun cl-remove-if (cl-pred cl-list &rest cl-keys) @@ -268,20 +283,21 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end (:start 0) :end) () - (if (<= (or cl-count (setq cl-count 8000000)) 0) + (let ((len (length cl-seq))) + (if (<= (or cl-count (setq cl-count len)) 0) cl-seq (if (listp cl-seq) - (if (and cl-from-end (< cl-count 4000000)) + (if (and cl-from-end (< cl-count (/ len 2))) (let (cl-i) (while (and (>= (setq cl-count (1- cl-count)) 0) (setq cl-i (cl--position cl-item cl-seq cl-start - cl-end cl-from-end))) + cl-end cl-from-end))) (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) (setcdr cl-tail (cdr (cdr cl-tail))))) (setq cl-end cl-i)) cl-seq) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (if (= cl-start 0) (progn (while (and cl-seq @@ -302,7 +318,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-p (cdr cl-p))) (setq cl-end (1- cl-end))))) cl-seq) - (apply 'cl-remove cl-item cl-seq cl-keys))))) + (apply 'cl-remove cl-item cl-seq cl-keys)))))) ;;;###autoload (defun cl-delete-if (cl-pred cl-list &rest cl-keys) @@ -337,6 +353,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) (cl--parsing-keywords + ;; We need to parse :if, otherwise `cl-if' is unbound. (:test :test-not :key (:start 0) :end :from-end :if) () (if cl-from-end @@ -385,15 +402,17 @@ to avoid corrupting the original SEQ. (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () (if (or (eq cl-old cl-new) - (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) + (<= (or cl-count (setq cl-from-end nil + cl-count (length cl-seq))) 0)) cl-seq (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end))) (if (not cl-i) cl-seq (setq cl-seq (copy-sequence cl-seq)) - (or cl-from-end - (progn (setf (elt cl-seq cl-i) cl-new) - (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) + (unless cl-from-end + (setf (elt cl-seq cl-i) cl-new) + (cl-incf cl-i) + (cl-decf cl-count)) (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) @@ -423,17 +442,18 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn NEW OLD SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:test :test-not :key :if :if-not :count (:start 0) :end :from-end) () - (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) - (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) + (let ((len (length cl-seq))) + (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count len)) 0) + (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count (/ len 2)))) (let ((cl-p (nthcdr cl-start cl-seq))) - (setq cl-end (- (or cl-end 8000000) cl-start)) + (setq cl-end (- (or cl-end len) cl-start)) (while (and cl-p (> cl-end 0) (> cl-count 0)) (if (cl--check-test cl-old (car cl-p)) (progn (setcar cl-p cl-new) (setq cl-count (1- cl-count)))) (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) - (or cl-end (setq cl-end (length cl-seq))) + (or cl-end (setq cl-end len)) (if cl-from-end (while (and (< cl-start cl-end) (> cl-count 0)) (setq cl-end (1- cl-end)) @@ -446,7 +466,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (progn (aset cl-seq cl-start cl-new) (setq cl-count (1- cl-count)))) - (setq cl-start (1+ cl-start)))))) + (setq cl-start (1+ cl-start))))))) cl-seq)) ;;;###autoload @@ -502,14 +522,13 @@ Return the index of the matching item, or nil if not found. (defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) (if (listp cl-seq) - (let ((cl-p (nthcdr cl-start cl-seq))) - (or cl-end (setq cl-end 8000000)) - (let ((cl-res nil)) - (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) + (let ((cl-p (nthcdr cl-start cl-seq)) + cl-res) + (while (and cl-p (or (null cl-end) (< cl-start cl-end)) (or (null cl-res) cl-from-end)) (if (cl--check-test cl-item (car cl-p)) (setq cl-res cl-start)) (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) - cl-res)) + cl-res) (or cl-end (setq cl-end (length cl-seq))) (if cl-from-end (progn @@ -774,7 +793,7 @@ to avoid corrupting the original LIST1 and LIST2. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - ((equal cl-list1 cl-list2) cl-list1) + ((and (not cl-keys) (equal cl-list1 cl-list2)) cl-list1) (t (or (>= (length cl-list1) (length cl-list2)) (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) @@ -849,7 +868,7 @@ to avoid corrupting the original LIST1 and LIST2. (memq (car cl-list1) cl-list2)) (push (car cl-list1) cl-res)) (pop cl-list1)) - cl-res)))) + (nreverse cl-res))))) ;;;###autoload (defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 46472ccd257..c3d3feae876 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,6 +1,6 @@ ;;; cl.el --- Compatibility aliases for the old CL library. -*- lexical-binding: t -*- -;; Copyright (C) 2012-2015 Free Software Foundation, Inc. +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -154,7 +154,6 @@ every some mapcon - mapcan mapl maplist map @@ -365,7 +364,7 @@ The two cases that are handled are: `(list 'lambda '(&rest --cl-rest--) ,@(cl-sublis sub (nreverse decls)) (list 'apply - (list 'quote + (list 'function #'(lambda ,(append new (cadr f)) ,@(cl-sublis sub body))) ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 50f880d7b33..e7e69059802 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,6 +1,6 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991-1995, 1998, 2001-2015 Free Software Foundation, +;; Copyright (C) 1991-1995, 1998, 2001-2016 Free Software Foundation, ;; Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 61cb3c3af4e..035baa0a967 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,6 +1,6 @@ ;;; crm.el --- read multiple strings with completion -;; Copyright (C) 1985-1986, 1993-2015 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1993-2016 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el index 1d1780baed0..2231179de1c 100644 --- a/lisp/emacs-lisp/cursor-sensor.el +++ b/lisp/emacs-lisp/cursor-sensor.el @@ -1,6 +1,6 @@ ;;; cursor-sensor.el --- React to cursor movement -*- lexical-binding: t; -*- -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: @@ -31,6 +31,7 @@ ;;; Code: +;;;###autoload (defvar cursor-sensor-inhibit nil) (defun cursor-sensor--intangible-p (pos) @@ -167,8 +168,8 @@ This property should hold a list of functions which react to the motion of the cursor. They're called with three arguments (WINDOW OLDPOS DIR) where WINDOW is the affected window, OLDPOS is the last known position of -the cursor and DIR can be `left' or `entered' depending on whether the cursor is -entering the area covered by the text-property property or leaving it." +the cursor and DIR can be `entered' or `left' depending on whether the cursor +is entering the area covered by the text-property property or leaving it." nil nil nil (if cursor-sensor-mode (add-hook 'pre-redisplay-functions #'cursor-sensor--detect diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0e307fae70a..5430b72545a 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,6 +1,6 @@ ;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1985-1986, 1994, 2001-2015 Free Software Foundation, +;; Copyright (C) 1985-1986, 1994, 2001-2016 Free Software Foundation, ;; Inc. ;; Maintainer: emacs-devel@gnu.org @@ -279,7 +279,9 @@ That buffer should be current already." (goto-char (point-min)) (delete-region (point) (progn - (search-forward "\n debug(") + (search-forward (if debugger-stack-frame-as-list + "\n (debug " + "\n debug(")) (forward-line (if (eq (car args) 'debug) ;; Remove debug--implement-debug-on-entry ;; and the advice's `apply' frame. @@ -304,6 +306,24 @@ That buffer should be current already." (delete-char 1) (insert ? ) (beginning-of-line)) + ;; Watchpoint triggered. + ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + (`(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %S" symbol newval)) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + (`(set nil) (format "setting %s to %S" symbol newval)) + (`(set ,buffer) (format "setting %s in buffer %s to %S" + symbol buffer newval)) + (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (setq pos (point)) + (insert ?\n)) ;; Debugger entered for an error. (`error (insert "--Lisp error: ") @@ -848,6 +868,79 @@ To specify a nil argument interactively, exit with an empty minibuffer." (princ "Note: if you have redefined a function, then it may no longer\n") (princ "be set to debug on entry, even if it is in the list.")))))) +(defun debug--implement-debug-watch (symbol newval op where) + "Conditionally call the debugger. +This function is called when SYMBOL's value is modified." + (if (or inhibit-debug-on-entry debugger-jumping-flag) + nil + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'watchpoint symbol newval op where)))) + +;;;###autoload +(defun debug-on-variable-change (variable) + "Trigger a debugger invocation when VARIABLE is changed. + +When called interactively, prompt for VARIABLE in the minibuffer. + +This works by calling `add-variable-watch' on VARIABLE. If you +quit from the debugger, this will abort the change (unless the +change is caused by the termination of a let-binding). + +The watchpoint may be circumvented by C code that changes the +variable directly (i.e., not via `set'). Changing the value of +the variable (e.g., `setcar' on a list variable) will not trigger +watchpoint. + +Use \\[cancel-debug-on-variable-change] to cancel the effect of +this command. Uninterning VARIABLE or making it an alias of +another symbol also cancels it." + (interactive + (let* ((var-at-point (variable-at-point)) + (var (and (symbolp var-at-point) var-at-point)) + (val (completing-read + (concat "Debug when setting variable" + (if var (format " (default %s): " var) ": ")) + obarray #'boundp + t nil nil (and var (symbol-name var))))) + (list (if (equal val "") var (intern val))))) + (add-variable-watcher variable #'debug--implement-debug-watch)) + +;;;###autoload +(defalias 'debug-watch #'debug-on-variable-change) + + +(defun debug--variable-list () + "List of variables currently set for debug on set." + (let ((vars '())) + (mapatoms + (lambda (s) + (when (memq #'debug--implement-debug-watch + (get s 'watchers)) + (push s vars)))) + vars)) + +;;;###autoload +(defun cancel-debug-on-variable-change (&optional variable) + "Undo effect of \\[debug-on-variable-change] on VARIABLE. +If VARIABLE is nil, cancel debug-on-variable-change for all variables. +When called interactively, prompt for VARIABLE in the minibuffer. +To specify a nil argument interactively, exit with an empty minibuffer." + (interactive + (list (let ((name + (completing-read + "Cancel debug on set for variable (default all variables): " + (mapcar #'symbol-name (debug--variable-list)) nil t))) + (when name + (unless (string= name "") + (intern name)))))) + (if variable + (remove-variable-watcher variable #'debug--implement-debug-watch) + (message "Canceling debug-watch for all variables") + (mapc #'cancel-debug-watch (debug--variable-list)))) + +;;;###autoload +(defalias 'cancel-debug-watch #'cancel-debug-on-variable-change) + (provide 'debug) ;;; debug.el ends here diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index ee137f1771e..0f7691af0f4 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,7 +1,7 @@ ;;; derived.el --- allow inheritance of major modes ;; (formerly mode-clone.el) -;; Copyright (C) 1993-1994, 1999, 2001-2015 Free Software Foundation, +;; Copyright (C) 1993-1994, 1999, 2001-2016 Free Software Foundation, ;; Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) @@ -137,6 +137,9 @@ BODY can start with a bunch of keyword arguments. The following keyword :abbrev-table TABLE Use TABLE instead of the default (CHILD-abbrev-table). A nil value means to simply use the same abbrev-table as the parent. +:after-hook FORM + A single lisp form which is evaluated after the mode hooks have been + run. It should not be quoted. Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: @@ -163,7 +166,12 @@ See Info node `(elisp)Derived Modes' for more details." (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) - (indent 3)) + ;; Ask not what + ;;(indent 3) + ;; can do for you, ask what it can do to others. IOW, the + ;; missing of indentation setting here is the indentation + ;; setting and not an oversight. + ) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be @@ -179,7 +187,8 @@ See Info node `(elisp)Derived Modes' for more details." (declare-abbrev t) (declare-syntax t) (hook (derived-mode-hook-name child)) - (group nil)) + (group nil) + (after-hook nil)) ;; Process the keyword args. (while (keywordp (car body)) @@ -187,6 +196,7 @@ See Info node `(elisp)Derived Modes' for more details." (`:group (setq group (pop body))) (`:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) (`:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) + (`:after-hook (setq after-hook (pop body))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -267,7 +277,11 @@ No problems result if this variable is not bound. ,@body ) ;; Run the hooks, if any. - (run-mode-hooks ',hook))))) + (run-mode-hooks ',hook) + ,@(when after-hook + `((if delay-mode-hooks + (push ',after-hook delayed-after-hook-forms) + ,after-hook))))))) ;; PUBLIC: find the ultimate class of a derived mode. @@ -339,7 +353,7 @@ which more-or-less shadow%s %s's corresponding table%s." (format "`%s' " parent)) "might have run,\nthis mode ")) (format "runs the hook `%s'" hook) - ", as the final step\nduring initialization."))) + ", as the final or penultimate step\nduring initialization."))) (unless (string-match "\\\\[{[]" docstring) ;; And don't forget to put the mode's keymap. diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 12cf605cce9..8506ed69669 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,6 +1,6 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -*- lexical-binding:t -*- -;; Copyright (C) 1986, 1991, 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2016 Free Software Foundation, Inc. ;; Author: Doug Cutting <doug@csli.stanford.edu> ;; Jamie Zawinski <jwz@lucid.com> @@ -54,9 +54,13 @@ OBJECT can be a symbol defined as a function, or a function itself \(a lambda expression or a compiled-function object). If OBJECT is not already compiled, we compile it, but do not redefine OBJECT if it is a symbol." - (interactive (list (intern (completing-read "Disassemble function: " - obarray 'fboundp t)) - nil 0 t)) + (interactive + (let* ((fn (function-called-at-point)) + (prompt (if fn (format "Disassemble function (default %s): " fn) + "Disassemble function: ")) + (def (and fn (symbol-name fn)))) + (list (intern (completing-read prompt obarray 'fboundp t nil nil def)) + nil 0 t))) (if (and (consp object) (not (functionp object))) (setq object `(lambda () ,object))) (or indent (setq indent 0)) ;Default indent to zero diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 56f95111ab8..38295c302ea 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,6 +1,6 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2000-2016 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> @@ -68,6 +68,7 @@ replacing its case-insensitive matches with the literal string in LIGHTER." "toggle-\\|-mode\\'" "" (symbol-name mode)))) " mode"))) + (setq name (replace-regexp-in-string "\\`Global-" "Global " name)) (if (not (stringp lighter)) name ;; Strip leading and trailing whitespace from LIGHTER. (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\s-+\\'" "" @@ -107,9 +108,10 @@ Optional LIGHTER is displayed in the mode line when the mode is on. Optional KEYMAP is the default keymap bound to the mode keymap. If non-nil, it should be a variable name (whose value is a keymap), or an expression that returns either a keymap or a list of - arguments for `easy-mmode-define-keymap'. If you supply a KEYMAP - argument that is not a symbol, this macro defines the variable - MODE-map and gives it the value that KEYMAP specifies. + (KEY . BINDING) pairs where KEY and BINDING are suitable for + `define-key'. If you supply a KEYMAP argument that is not a + symbol, this macro defines the variable MODE-map and gives it + the value that KEYMAP specifies. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. @@ -148,16 +150,15 @@ BODY contains code to execute each time the mode is enabled or disabled. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" - :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" + :lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version \"27.5\" ...BODY CODE...)" (declare (doc-string 2) (debug (&define name string-or-null-p - [&optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp] - [&rest [keywordp sexp]] - def-body)) - (indent 1)) + [&optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp] + [&rest [keywordp sexp]] + def-body))) ;; Allow skipping the first three args. (cond @@ -252,7 +253,8 @@ Use the command `%s' to change this variable." pretty-name mode)) (t (let ((base-doc-string (concat "Non-nil if %s is enabled. -See the command `%s' for a description of this minor mode." +See the `%s' command +for a description of this minor mode." (if body " Setting this variable directly does not take effect; either customize it (see the info node `Easy Customization') @@ -502,7 +504,7 @@ Valid keywords and arguments are: :inherit Parent keymap. :group Ignored. :suppress Non-nil to call `suppress-keymap' on keymap, - 'nodigits to suppress digits as prefix arguments." + `nodigits' to suppress digits as prefix arguments." (let (inherit dense suppress) (while args (let ((key (pop args)) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index ad2ba6994f2..189bb6c8d87 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,6 +1,6 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu -*- lexical-binding:t -*- -;; Copyright (C) 1994, 1996, 1998-2015 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998-2016 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a3e3b567cc4..66117b83316 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,6 +1,6 @@ ;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*- -;; Copyright (C) 1988-1995, 1997, 1999-2015 Free Software Foundation, +;; Copyright (C) 1988-1995, 1997, 1999-2016 Free Software Foundation, ;; Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> @@ -225,6 +225,7 @@ After execution is resumed, the error is signaled again." "If non-nil, an expression to test for at every stop point. If the result is non-nil, then break. Errors are ignored." :type 'sexp + :risky t :group 'edebug) (defcustom edebug-sit-for-seconds 1 @@ -232,6 +233,12 @@ If the result is non-nil, then break. Errors are ignored." :type 'number :group 'edebug) +(defcustom edebug-sit-on-break t + "Whether or not to pause for `edebug-sit-for-seconds' on reaching a break." + :type 'boolean + :group 'edebug + :version "26.1") + ;;; Form spec utilities. (defun get-edebug-spec (symbol) @@ -1926,6 +1933,7 @@ expressions; a `progn' form will be returned enclosing these forms." (def-edebug-spec defun (&define name lambda-list [&optional stringp] + [&optional ("declare" &rest sexp)] [&optional ("interactive" interactive)] def-body)) (def-edebug-spec defmacro @@ -2355,7 +2363,7 @@ MSG is printed after `::::} '." (defvar edebug-window-data) ; window and window-start for current function (defvar edebug-outside-windows) ; outside window configuration (defvar edebug-eval-buffer) ; for the evaluation list. -(defvar edebug-outside-d-c-i-n-s-w) ; outside default-cursor-in-non-selected-windows +(defvar edebug-outside-d-c-i-n-s-w) ; outside default cursor-in-non-selected-windows (defvar edebug-eval-list nil) ;; List of expressions to evaluate. @@ -2488,6 +2496,7 @@ MSG is printed after `::::} '." (progn ;; Display result of previous evaluation. (if (and edebug-break + edebug-sit-on-break (not (eq edebug-execution-mode 'Continue-fast))) (sit-for edebug-sit-for-seconds)) ; Show message. (edebug-previous-result))) @@ -3789,7 +3798,9 @@ Otherwise call `debug' normally." (forward-line 1) (delete-region last-ok-point (point))) - ((looking-at "^ edebug") + ((looking-at (if debugger-stack-frame-as-list + "^ (edebug" + "^ edebug")) (forward-line 1) (delete-region last-ok-point (point)) ))) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 400bdb95c06..b99905cf198 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,6 +1,6 @@ ;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2015 Free Software +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2016 Free Software ;;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 638c475ef2b..413b94f01a8 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -1,9 +1,10 @@ ;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*- -;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2016 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -143,7 +144,7 @@ Summary: ;; Give it a slightly higher priority than `class' so that the ;; interleaved list comes before the class's non-interleaved list. 51 #'cl--generic-struct-tag - (lambda (tag _targets) + (lambda (tag &rest _) (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) (eieio--class-p tag) (let ((superclasses (eieio--class-precedence-list tag)) @@ -187,7 +188,8 @@ Summary: (`no-applicable-method (setq method 'cl-no-applicable-method) (setq specializers `(generic ,@specializers)) - (lambda (generic arg &rest args) (apply code arg generic args))) + (lambda (generic arg &rest args) + (apply code arg (cl--generic-name generic) (cons arg args)))) (_ code)))) (cl-generic-define-method method (unless (memq kind '(nil :primary)) (list kind)) @@ -264,7 +266,7 @@ Summary: ;; Local Variables: -;; generated-autoload-file: "eieio-core.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: (provide 'eieio-compat) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 7011a30656b..624dccef075 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1,6 +1,6 @@ ;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- -;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2016 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.4 @@ -33,6 +33,7 @@ (require 'cl-lib) (require 'pcase) +(require 'eieio-loaddefs) ;;; ;; A few functions that are better in the official EIEIO src, but @@ -459,7 +460,7 @@ See `defclass' for more information." (cl--slot-descriptor-initform (aref slots i))))) (setf (eieio--class-class-allocation-values newc) v)) - ;; Attach slot symbols into a hashtable, and store the index of + ;; Attach slot symbols into a hash table, and store the index of ;; this slot as the value this table. (let* ((slots (eieio--class-slots newc)) ;; (cslots (eieio--class-class-slots newc)) @@ -756,9 +757,7 @@ Argument FN is the function calling this verifier." ;; The slot-missing method is a cool way of allowing an object author ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) + (slot-missing obj slot 'oref)) (cl-check-type obj eieio-object) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -780,9 +779,7 @@ Fills in OBJ's SLOT with its default value." ;; Oref that slot. (aref (eieio--class-class-allocation-values cl) c) - (slot-missing obj slot 'oref-default) - ;;(signal 'invalid-slot-name (list (class-name cl) slot)) - ) + (slot-missing obj slot 'oref-default)) (eieio-barf-if-slot-unbound (let ((val (cl--slot-descriptor-initform (aref (eieio--class-slots cl) @@ -822,9 +819,7 @@ Fills in OBJ's SLOT with VALUE." (aset (eieio--class-class-allocation-values class) c value)) ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value) - ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) - ) + (slot-missing obj slot 'oset value)) (eieio--validate-slot-value class c value slot) (aset obj c value)))) @@ -976,7 +971,7 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio--class-parents (cl--find-class class)))) + (let ((parents (eieio--class-parents class))) (eieio--c3-merge-lists (list class) (append @@ -1070,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. @@ -1098,100 +1094,10 @@ 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)) - -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "bd51800d7de6429a2c9a6a600ba2dc52") -;;; Generated autoloads from eieio-compat.el - -(autoload 'eieio--defalias "eieio-compat" "\ -Like `defalias', but with less side-effects. -More specifically, it has no side-effects at all when the new function -definition is the same (`eq') as the old one. - -\(fn NAME BODY)" nil nil) - -(autoload 'defgeneric "eieio-compat" "\ -Create a generic function METHOD. -DOC-STRING is the base documentation for this class. A generic -function has no body, as its purpose is to decide which method body -is appropriate to use. Uses `defmethod' to create methods, and calls -`defgeneric' for you. With this implementation the ARGS are -currently ignored. You can use `defgeneric' to apply specialized -top level documentation to a method. - -\(fn METHOD ARGS &optional DOC-STRING)" nil t) - -(function-put 'defgeneric 'doc-string-elt '3) - -(make-obsolete 'defgeneric 'cl-defgeneric '"25.1") - -(autoload 'defmethod "eieio-compat" "\ -Create a new METHOD through `defgeneric' with ARGS. - -The optional second argument KEY is a specifier that -modifies how the method is called, including: - :before - Method will be called before the :primary - :primary - The default if not specified - :after - Method will be called after the :primary - :static - First arg could be an object or class -The next argument is the ARGLIST. The ARGLIST specifies the arguments -to the method as with `defun'. The first argument can have a type -specifier, such as: - ((VARNAME CLASS) ARG2 ...) -where VARNAME is the name of the local variable for the method being -created. The CLASS is a class symbol for a class made with `defclass'. -A DOCSTRING comes after the ARGLIST, and is optional. -All the rest of the args are the BODY of the method. A method will -return the value of the last form in the BODY. - -Summary: - - (defmethod mymethod [:before | :primary | :after | :static] - ((typearg class-name) arg2 &optional opt &rest rest) - \"doc-string\" - body) - -\(fn METHOD &rest ARGS)" nil t) - -(function-put 'defmethod 'doc-string-elt '3) - -(make-obsolete 'defmethod 'cl-defmethod '"25.1") - -(autoload 'eieio--defgeneric-init-form "eieio-compat" "\ - - -\(fn METHOD DOC-STRING)" nil nil) - -(autoload 'eieio--defmethod "eieio-compat" "\ - - -\(fn METHOD KIND ARGCLASS CODE)" nil nil) - -(autoload 'eieio-defmethod "eieio-compat" "\ -Obsolete work part of an old version of the `defmethod' macro. - -\(fn METHOD ARGS)" nil nil) - -(make-obsolete 'eieio-defmethod 'cl-defmethod '"24.1") - -(autoload 'eieio-defgeneric "eieio-compat" "\ -Obsolete work part of an old version of the `defgeneric' macro. - -\(fn METHOD DOC-STRING)" nil nil) - -(make-obsolete 'eieio-defgeneric 'cl-defgeneric '"24.1") - -(autoload 'eieio-defclass "eieio-compat" "\ - - -\(fn CNAME SUPERCLASSES SLOTS OPTIONS)" nil nil) - -(make-obsolete 'eieio-defclass 'eieio-defclass-internal '"25.1") - -;;;*** - - (provide 'eieio-core) ;;; eieio-core.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 31d0b85c55a..d2d87ea1537 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,6 +1,6 @@ ;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*- -;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, +;; Copyright (C) 1999-2001, 2005, 2007-2016 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -473,7 +473,7 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) ;; Local variables: -;; generated-autoload-file: "eieio.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index c820180359b..0eaec49be33 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,6 +1,6 @@ ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*- -;; Copyright (C) 2007-2015 Free Software Foundation, Inc. +;; Copyright (C) 2007-2016 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index a5d8b6fcf89..2f1d69f78f8 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,6 +1,6 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998-2003, 2005, 2008-2015 Free Software +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2016 Free Software ;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -162,7 +162,7 @@ are not abstract." (defun eieio-display-method-list () "Display a list of all the methods and what features are used." (interactive) - (let* ((meth1 (cl--generic-all-functions)) + (let* ((meth1 (cl-generic-all-functions)) (meth (sort meth1 (lambda (a b) (string< (symbol-name a) (symbol-name b))))) @@ -349,7 +349,7 @@ INDENT is the current indentation level." (provide 'eieio-opt) ;; Local variables: -;; generated-autoload-file: "eieio.el" +;; generated-autoload-file: "eieio-loaddefs.el" ;; End: ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index a1eabcf9700..6f717c87239 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,6 +1,6 @@ ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*- -;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, +;; Copyright (C) 1999-2002, 2005, 2007-2016 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 790e8bc9e0e..fd77654f105 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,7 +1,7 @@ ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- ;;; or maybe Eric's Implementation of Emacs Interpreted Objects -;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2016 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.4 @@ -235,7 +235,7 @@ This method is obsolete." (let ((f (intern (format "%s-child-p" name)))) `((defalias ',f ',testsym2) (make-obsolete - ',f ,(format "use (cl-typep ... \\='%s) instead" name) + ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) ;; When using typep, (typep OBJ 'myclass) returns t for objects which @@ -678,7 +678,8 @@ This class is not stored in the `parent' slot of a class vector." (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) -(defalias 'standard-class 'eieio-default-superclass) +(define-obsolete-function-alias 'standard-class + 'eieio-default-superclass "26.1") (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. @@ -765,11 +766,7 @@ dynamically set from SLOTS." ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) -(cl-defgeneric slot-missing (object slot-name operation &optional new-value) - "Method invoked when an attempt to access a slot in OBJECT fails.") - -(cl-defmethod slot-missing ((object eieio-default-superclass) slot-name - _operation &optional _new-value) +(cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. SLOT-NAME is the name of the failed slot, OPERATION is the type of access that was requested, and optional NEW-VALUE is the value that was desired @@ -777,8 +774,9 @@ to be set. This method is called from `oref', `oset', and other functions which directly reference slots in EIEIO objects." - (signal 'invalid-slot-name (list (eieio-object-name object) - slot-name))) + (signal 'invalid-slot-name + (list (if (eieio-object-p object) (eieio-object-name object) object) + slot-name))) (cl-defgeneric slot-unbound (object class slot-name fn) "Slot unbound is invoked during an attempt to reference an unbound slot.") @@ -815,22 +813,19 @@ first and modify the returned object.") (if params (shared-initialize nobj params)) nobj)) -(cl-defgeneric destructor (this &rest params) - "Destructor for cleaning up any dynamic links to our object.") - -(cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) - "Destructor for cleaning up any dynamic links to our object. -Argument THIS is the object being destroyed. PARAMS are additional -ignored parameters." +(cl-defgeneric destructor (_this &rest _params) + "Destructor for cleaning up any dynamic links to our object." + (declare (obsolete nil "26.1")) ;; No cleanup... yet. - ) + nil) -(cl-defgeneric object-print (this &rest strings) - "Pretty printer for object THIS. Call function `object-name' with STRINGS. +(cl-defgeneric object-print (this &rest _strings) + "Pretty printer for object THIS. It is sometimes useful to put a summary of the object into the default #<notation> string when using EIEIO browsing tools. -Implement this method to customize the summary.") +Implement this method to customize the summary." + (format "%S" this)) (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) "Pretty printer for object THIS. Call function `object-name' with STRINGS. @@ -938,11 +933,12 @@ this object." ;;; Unimplemented functions from CLOS ;; -(defun change-class (_obj _class) +(defun eieio-change-class (_obj _class) "Change the class of OBJ to type CLASS. This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) +(define-obsolete-function-alias 'change-class 'eieio-change-class "26.1") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the @@ -970,41 +966,6 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to (advice-add 'edebug-prin1-to-string :around #'eieio-edebug-prin1-to-string) - -;;; Start of automatically extracted autoloads. - -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "916f54b818479a77a02f3ecccda84a11") -;;; Generated autoloads from eieio-custom.el - -(autoload 'customize-object "eieio-custom" "\ -Customize OBJ in a custom buffer. -Optional argument GROUP is the sub-group of slots to display. - -\(fn OBJ &optional GROUP)" nil nil) - -;;;*** - -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d00419c898056fadf2f8e491f864aa1e") -;;; Generated autoloads from eieio-opt.el - -(autoload 'eieio-browse "eieio-opt" "\ -Create an object browser window to show all objects. -If optional ROOT-CLASS, then start with that, otherwise start with -variable `eieio-default-superclass'. - -\(fn &optional ROOT-CLASS)" t nil) - -(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") - -(autoload 'eieio-help-constructor "eieio-opt" "\ -Describe CTR if it is a class constructor. - -\(fn CTR)" nil nil) - -;;;*** - -;;; End of automatically extracted autoloads. - (provide 'eieio) ;;; eieio ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index bbc8e153f74..6c2f869f260 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,6 +1,6 @@ ;;; eldoc.el --- Show function arglist or variable docstring in echo area -*- lexical-binding:t; -*- -;; Copyright (C) 1996-2015 Free Software Foundation, Inc. +;; Copyright (C) 1996-2016 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Maintainer: friedman@splode.com @@ -197,12 +197,23 @@ expression point is on." (t (kill-local-variable 'eldoc-message-commands) (remove-hook 'post-command-hook 'eldoc-schedule-timer t) - (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t)))) + (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t) + (when eldoc-timer + (cancel-timer eldoc-timer) + (setq eldoc-timer nil))))) ;;;###autoload (define-minor-mode global-eldoc-mode - "Enable `eldoc-mode' in all buffers where it's applicable." - :group 'eldoc :global t + "Toggle Global Eldoc mode on or off. +With a prefix argument ARG, enable Global Eldoc mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil, and toggle it if ARG is ‘toggle’. + +If Global Eldoc mode is on, `eldoc-mode' will be enabled in all +buffers where it's applicable. These are buffers that have modes +that have enabled eldoc support. See `eldoc-documentation-function'." + :group 'eldoc + :global t :initialize 'custom-initialize-delay :init-value t (setq eldoc-last-message nil) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 64d65c05902..7f0f947ec04 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,6 +1,6 @@ ;;; elint.el --- Lint Emacs Lisp -;; Copyright (C) 1997, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001-2016 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 39d62ad34a0..ad93e69eba2 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,6 +1,6 @@ ;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- -;; Copyright (C) 1994-1995, 1997-1998, 2001-2015 Free Software +;; Copyright (C) 1994-1995, 1997-1998, 2001-2016 Free Software ;; Foundation, Inc. ;; Author: Barry A. Warsaw diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index f899f40fb80..2a2418fa7d2 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -1,6 +1,6 @@ ;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- -;; Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. ;; Author: Lennart Borgman (lennart O borgman A gmail O com) ;; Christian Ohler <ohler@gnu.org> diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 21c1f1be394..0308c9cd37c 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,6 +1,6 @@ ;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- -;; Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. +;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. ;; Author: Christian Ohler <ohler@gnu.org> ;; Keywords: lisp, tools @@ -187,7 +187,7 @@ using :expected-result. See `ert-test-result-type-p' for a description of valid values for RESULT-TYPE. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ -[:tags '(TAG...)] BODY...)" +[:tags \\='(TAG...)] BODY...)" (declare (debug (&define :name test name sexp [&optional stringp] [&rest keywordp sexp] def-body)) @@ -374,9 +374,9 @@ Returns nil." Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signaled-conditions (get (car condition) 'error-conditions)) - (handled-conditions (cl-etypecase type - (list type) - (symbol (list type))))) + (handled-conditions (pcase-exhaustive type + ((pred listp) type) + ((pred symbolp) (list type))))) (cl-assert signaled-conditions) (unless (cl-intersection signaled-conditions handled-conditions) (ert-fail (append @@ -466,18 +466,18 @@ Errors during evaluation are caught and handled like nil." (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." - (cl-typecase x - (character (list x (format "#x%x" x) (format "?%c" x))) - (fixnum (list x (format "#x%x" x))) - (t x))) + (pcase x + ((pred characterp) (list x (format "#x%x" x) (format "?%c" x))) + ((pred integerp) (list x (format "#x%x" x))) + (_ x))) (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. Returns nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) - (cl-etypecase a - (cons + (pcase-exhaustive a + ((pred consp) (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) (if (not (eql (not a-proper-p) (not b-proper-p))) @@ -502,24 +502,26 @@ Returns nil if they are." `(cdr ,cdr-x) (cl-assert (equal a b) t) nil)))))))) - (array (if (not (equal (length a) (length b))) - `(arrays-of-different-length ,(length a) ,(length b) - ,a ,b - ,@(unless (char-table-p a) - `(first-mismatch-at - ,(cl-mismatch a b :test 'equal)))) - (cl-loop for i from 0 - for ai across a - for bi across b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (cl-return `(array-elt ,i ,xi))) - finally (cl-assert (equal a b) t)))) - (atom (if (not (equal a b)) - (if (and (symbolp a) (symbolp b) (string= a b)) - `(different-symbols-with-the-same-name ,a ,b) - `(different-atoms ,(ert--explain-format-atom a) - ,(ert--explain-format-atom b))) - nil))))) + ((pred arrayp) + (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(cl-mismatch a b :test 'equal)))) + (cl-loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(array-elt ,i ,xi))) + finally (cl-assert (equal a b) t)))) + ((pred atom) + (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) (defun ert--explain-equal (a b) "Explainer function for `equal'." @@ -694,23 +696,20 @@ and is displayed in front of the value of MESSAGE-FORM." (print-level 8) (print-length 50)) (dolist (frame backtrace) - (cl-ecase (car frame) - ((nil) + (pcase-exhaustive frame + (`(nil ,special-operator . ,arg-forms) ;; Special operator. - (cl-destructuring-bind (special-operator &rest arg-forms) - (cdr frame) - (insert - (format " %S\n" (cons special-operator arg-forms))))) - ((t) + (insert + (format " %S\n" (cons special-operator arg-forms)))) + (`(t ,fn . ,args) ;; Function call. - (cl-destructuring-bind (fn &rest args) (cdr frame) - (insert (format " %S(" fn)) - (cl-loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) - (insert ")\n"))))))) + (insert (format " %S(" fn)) + (cl-loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n")))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. @@ -894,33 +893,32 @@ t -- Always matches. RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. - (cl-etypecase result-type - ((member nil) nil) - ((member t) t) - ((member :failed) (ert-test-failed-p result)) - ((member :passed) (ert-test-passed-p result)) - ((member :skipped) (ert-test-skipped-p result)) - (cons - (cl-destructuring-bind (operator &rest operands) result-type - (cl-ecase operator - (and - (cl-case (length operands) - (0 t) - (t - (and (ert-test-result-type-p result (car operands)) - (ert-test-result-type-p result `(and ,@(cdr operands))))))) - (or - (cl-case (length operands) - (0 nil) - (t - (or (ert-test-result-type-p result (car operands)) - (ert-test-result-type-p result `(or ,@(cdr operands))))))) - (not - (cl-assert (eql (length operands) 1)) - (not (ert-test-result-type-p result (car operands)))) - (satisfies - (cl-assert (eql (length operands) 1)) - (funcall (car operands) result))))))) + (pcase-exhaustive result-type + ('nil nil) + ('t t) + (:failed (ert-test-failed-p result)) + (:passed (ert-test-passed-p result)) + (:skipped (ert-test-skipped-p result)) + (`(,operator . ,operands) + (cl-ecase operator + (and + (cl-case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(and ,@(cdr operands))))))) + (or + (cl-case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(or ,@(cdr operands))))))) + (not + (cl-assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (car operands)))) + (satisfies + (cl-assert (eql (length operands) 1)) + (funcall (car operands) result)))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." @@ -961,95 +959,96 @@ as (satisfies ...), strings, :new, etc. make use of UNIVERSE. Selectors that do not, such as (member ...), just return the set implied by them without checking whether it is really contained in UNIVERSE." - ;; This code needs to match the etypecase in + ;; This code needs to match the cases in ;; `ert-insert-human-readable-selector'. - (cl-etypecase selector - ((member nil) nil) - ((member t) (cl-etypecase universe - (list universe) - ((member t) (ert-select-tests "" universe)))) - ((member :new) (ert-select-tests - `(satisfies ,(lambda (test) - (null (ert-test-most-recent-result test)))) - universe)) - ((member :failed) (ert-select-tests - `(satisfies ,(lambda (test) - (ert-test-result-type-p - (ert-test-most-recent-result test) - ':failed))) - universe)) - ((member :passed) (ert-select-tests - `(satisfies ,(lambda (test) - (ert-test-result-type-p - (ert-test-most-recent-result test) - ':passed))) - universe)) - ((member :expected) (ert-select-tests - `(satisfies - ,(lambda (test) - (ert-test-result-expected-p - test - (ert-test-most-recent-result test)))) - universe)) - ((member :unexpected) (ert-select-tests `(not :expected) universe)) - (string - (cl-etypecase universe - ((member t) (mapcar #'ert-get-test - (apropos-internal selector #'ert-test-boundp))) - (list (cl-remove-if-not (lambda (test) - (and (ert-test-name test) - (string-match selector - (symbol-name - (ert-test-name test))))) - universe)))) - (ert-test (list selector)) - (symbol + (pcase-exhaustive selector + ('nil nil) + ('t (pcase-exhaustive universe + ((pred listp) universe) + (`t (ert-select-tests "" universe)))) + (:new (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + (:failed (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + (:passed (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + (:expected (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + (:unexpected (ert-select-tests `(not :expected) universe)) + ((pred stringp) + (pcase-exhaustive universe + (`t (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + ((pred listp) + (cl-remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (symbol-name + (ert-test-name test))))) + universe)))) + ((pred ert-test-p) (list selector)) + ((pred symbolp) (cl-assert (ert-test-boundp selector)) (list (ert-get-test selector))) - (cons - (cl-destructuring-bind (operator &rest operands) selector - (cl-ecase operator - (member - (mapcar (lambda (purported-test) - (cl-etypecase purported-test - (symbol (cl-assert (ert-test-boundp purported-test)) - (ert-get-test purported-test)) - (ert-test purported-test))) - operands)) - (eql - (cl-assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (cl-case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(cdr operands)) - (ert-select-tests (car operands) - universe))))) - (not - (cl-assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (cl-set-difference all-tests - (ert-select-tests (car operands) - all-tests)))) - (or - (cl-case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (cl-union (ert-select-tests (car operands) universe) - (ert-select-tests `(or ,@(cdr operands)) - universe))))) - (tag - (cl-assert (eql (length operands) 1)) - (let ((tag (car operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (cl-assert (eql (length operands) 1)) - (cl-remove-if-not (car operands) - (ert-select-tests 't universe)))))))) + (`(,operator . ,operands) + (cl-ecase operator + (member + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (cl-assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (eql + (cl-assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (cl-case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(cdr operands)) + (ert-select-tests (car operands) + universe))))) + (not + (cl-assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests (car operands) + all-tests)))) + (or + (cl-case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (cl-union (ert-select-tests (car operands) universe) + (ert-select-tests `(or ,@(cdr operands)) + universe))))) + (tag + (cl-assert (eql (length operands) 1)) + (let ((tag (car operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (cl-assert (eql (length operands) 1)) + (cl-remove-if-not (car operands) + (ert-select-tests 't universe))))))) (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." @@ -1058,26 +1057,24 @@ contained in UNIVERSE." ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. (cl-labels ((rec (selector) - ;; This code needs to match the etypecase in + ;; This code needs to match the cases in ;; `ert-select-tests'. - (cl-etypecase selector - ((or (member nil t - :new :failed :passed - :expected :unexpected) - string - symbol) + (pcase-exhaustive selector + ((or + ;; 'nil 't :new :failed :passed :expected :unexpected + (pred stringp) + (pred symbolp)) selector) - (ert-test + ((pred ert-test-p) (if (ert-test-name selector) (make-symbol (format "<%S>" (ert-test-name selector))) (make-symbol "<unnamed test>"))) - (cons - (cl-destructuring-bind (operator &rest operands) selector - (cl-ecase operator - ((member eql and not or) - `(,operator ,@(mapcar #'rec operands))) - ((member tag satisfies) - selector))))))) + (`(,operator . ,operands) + (pcase operator + ((or 'member 'eql 'and 'not 'or) + `(,operator ,@(mapcar #'rec operands))) + ((or 'tag 'satisfies) + selector)))))) (insert (format "%S" (rec selector))))) @@ -1473,7 +1470,7 @@ this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." (user-error "This function is only for use in batch mode")) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) - nnotrun logfile notests badtests unexpected) + nnotrun logfile notests badtests unexpected skipped) (with-temp-buffer (while (setq logfile (pop command-line-args-left)) (erase-buffer) @@ -1493,9 +1490,10 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (push logfile unexpected) (setq nunexpected (+ nunexpected (string-to-number (match-string 4))))) - (if (match-string 5) - (setq nskipped (+ nskipped - (string-to-number (match-string 5))))))))) + (when (match-string 5) + (push logfile skipped) + (setq nskipped (+ nskipped + (string-to-number (match-string 5))))))))) (setq nnotrun (- ntests nrun)) (message "\nSUMMARY OF TEST RESULTS") (message "-----------------------") @@ -1519,6 +1517,26 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (when unexpected (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) + ;; More details on hydra, where the logs are harder to get to. + (when (and (getenv "NIX_STORE") + (not (zerop (+ nunexpected nskipped)))) + (message "\nDETAILS") + (message "-------") + (with-temp-buffer + (dolist (x (list (list skipped "skipped" "SKIPPED") + (list unexpected "unexpected" "FAILED"))) + (mapc (lambda (l) + (erase-buffer) + (insert-file-contents l) + (message "%s:" l) + (when (re-search-forward (format "^[ \t]*[0-9]+ %s results:" + (nth 1 x)) + nil t) + (while (and (zerop (forward-line 1)) + (looking-at (format "^[ \t]*%s" (nth 2 x)))) + (message "%s" (buffer-substring (line-beginning-position) + (line-end-position)))))) + (car x))))) (kill-emacs (cond ((or notests badtests (not (zerop nnotrun))) 2) (unexpected 1) (t 0))))) @@ -2131,12 +2149,12 @@ To be used in the ERT results buffer." "Move point from NODE to the previous or next node. EWOC-FN specifies the direction and should be either `ewoc-prev' -or `ewoc-next'. If there are no more nodes in that direction, an -error is signaled with the message ERROR-MESSAGE." +or `ewoc-next'. If there are no more nodes in that direction, a +user-error is signaled with the message ERROR-MESSAGE." (cl-loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) - (error "%s" error-message)) + (user-error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) (cl-return)))) @@ -2463,7 +2481,7 @@ To be used in the ERT results buffer." stats) for end-time across (ert--stats-test-end-times stats) collect (list test - (float-time (subtract-time + (float-time (time-subtract end-time start-time)))))) (setq data (sort data (lambda (a b) (> (cl-second a) (cl-second b))))) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 1f0c25e8205..932b7fb2623 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,6 +1,6 @@ ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- -;; Copyright (C) 1991-2015 Free Software Foundation, Inc. +;; Copyright (C) 1991-2016 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 69d545560d4..cbb134e95d5 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,6 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- -;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2016 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp @@ -43,6 +43,8 @@ ;;; Code: +(require 'seq) + ;;; User variables: (defgroup find-function nil @@ -103,7 +105,7 @@ Please send improvements and fixes to the maintainer." (defcustom find-feature-regexp (concat ";;; Code:") "The regexp used by `xref-find-definitions' when searching for a feature definition. -Note it must contain a `%s' at the place where `format' +Note it may contain up to one `%s' at the place where `format' should insert the feature name." ;; We search for ";;; Code" rather than (feature '%s) because the ;; former is near the start of the code, and the latter is very @@ -111,7 +113,7 @@ should insert the feature name." ;; (point-min), which is acceptable in this case. :type 'regexp :group 'xref - :version "25.0") + :version "25.1") (defcustom find-alias-regexp "(defalias +'%s" @@ -120,7 +122,7 @@ Note it must contain a `%s' at the place where `format' should insert the feature name." :type 'regexp :group 'xref - :version "25.0") + :version "25.1") (defvar find-function-regexp-alist '((nil . find-function-regexp) @@ -182,15 +184,15 @@ See the functions `find-function' and `find-variable'." LIBRARY should be a string (the name of the library)." ;; If the library is byte-compiled, try to find a source library by ;; the same name. - (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) - (setq library (replace-match "" t t library))) + (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) + (setq library (replace-match "" t t library))) (or (locate-file library - (or find-function-source-path load-path) - (find-library-suffixes)) + (or find-function-source-path load-path) + (find-library-suffixes)) (locate-file library - (or find-function-source-path load-path) - load-file-rep-suffixes) + (or find-function-source-path load-path) + load-file-rep-suffixes) (when (file-name-absolute-p library) (let ((rel (find-library--load-name library))) (when rel @@ -201,8 +203,44 @@ LIBRARY should be a string (the name of the library)." (locate-file rel (or find-function-source-path load-path) load-file-rep-suffixes))))) + (find-library--from-load-path library) (error "Can't find library %s" library))) +(defun find-library--from-load-path (library) + ;; In `load-history', the file may be ".elc", ".el", ".el.gz", and + ;; LIBRARY may be "foo.el" or "foo", so make sure that we get all + ;; potential matches, and then see whether any of them lead us to an + ;; ".el" or an ".el.gz" file. + (let* ((elc-regexp "\\.el\\(c\\(\\..*\\)?\\)\\'") + (suffix-regexp + (concat "\\(" + (mapconcat 'regexp-quote (find-library-suffixes) "\\'\\|") + "\\|" elc-regexp "\\)\\'")) + (potentials + (mapcar + (lambda (entry) + (if (string-match suffix-regexp (car entry)) + (replace-match "" t t (car entry)) + (car entry))) + (seq-filter + (lambda (entry) + (string-match + (concat "\\`" + (regexp-quote + (replace-regexp-in-string suffix-regexp "" library)) + suffix-regexp) + (file-name-nondirectory (car entry)))) + load-history))) + result) + (dolist (file potentials) + (dolist (suffix (find-library-suffixes)) + (when (not result) + (cond ((file-exists-p file) + (setq result file)) + ((file-exists-p (concat file suffix)) + (setq result (concat file suffix))))))) + result)) + (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) (if (file-accessible-directory-p dir) dir)) @@ -255,9 +293,12 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (cons (current-buffer) (match-beginning 0)))) ;;;###autoload -(defun find-library (library) +(defun find-library (library &optional other-window) "Find the Emacs Lisp source of LIBRARY. -LIBRARY should be a string (the name of the library)." +LIBRARY should be a string (the name of the library). If the +optional OTHER-WINDOW argument (i.e., the command argument) is +specified, pop to a different window before displaying the +buffer." (interactive (let* ((dirs (or find-function-source-path load-path)) (suffixes (find-library-suffixes)) @@ -279,11 +320,17 @@ LIBRARY should be a string (the name of the library)." (when (and def (not (test-completion def table))) (setq def nil)) (list - (completing-read (if def (format "Library name (default %s): " def) + (completing-read (if def + (format "Library name (default %s): " def) "Library name: ") - table nil nil nil nil def)))) - (let ((buf (find-file-noselect (find-library-name library)))) - (condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf))))) + table nil nil nil nil def) + current-prefix-arg))) + (prog1 + (funcall (if other-window + 'pop-to-buffer + 'pop-to-buffer-same-window) + (find-file-noselect (find-library-name library))) + (run-hooks 'find-function-after-hook))) ;;;###autoload (defun find-function-search-for-symbol (symbol type library) @@ -357,8 +404,10 @@ signal an error. If VERBOSE is non-nil, and FUNCTION is an alias, display a message about the whole chain of aliases." - (let ((def (if (symbolp function) - (find-function-advised-original function))) + (let ((def (when (symbolp function) + (or (fboundp function) + (signal 'void-function (list function))) + (find-function-advised-original function))) aliases) ;; FIXME for completeness, it might be nice to print something like: ;; foo (which is advised), which is an alias for bar (which is advised). diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 0320662af94..a3d89e4f3a1 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,6 +1,6 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985-1987, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 2001-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 123f64b9660..49af240bb65 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -1,6 +1,6 @@ ;;; generator.el --- generators -*- lexical-binding: t -*- -;;; Copyright (C) 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; Author: Daniel Colascione <dancol@dancol.org> ;; Keywords: extensions, elisp diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index b7f4070cf60..a6cf12b0cfc 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,6 +1,6 @@ ;;; generic.el --- defining simple major modes with comment and font-lock ;; -;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2016 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 94fe6c3d441..fa7ac64bf04 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -1,6 +1,6 @@ ;;; gv.el --- generalized variables -*- lexical-binding: t -*- -;; Copyright (C) 2012-2015 Free Software Foundation, Inc. +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions @@ -260,6 +260,8 @@ The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" (declare (debug (&rest [gv-place form]))) + (if (/= (logand (length args) 1) 0) + (signal 'wrong-number-of-arguments (list 'setf (length args)))) (if (and args (null (cddr args))) (let ((place (pop args)) (val (car args))) @@ -534,7 +536,7 @@ This macro only makes sense when used in a place." "Return a reference to PLACE. This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very -simple PLACEs such as (function-symbol 'foo) which will also work in dynamic +simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic binding mode." (let ((code (gv-letplace (getter setter) place diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 8b7737b1d3e..a35dc09e467 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,6 +1,6 @@ ;;; helper.el --- utility help package supporting help in electric modes -;; Copyright (C) 1985, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2016 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index c3f696feda1..058c56c3b49 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -1,6 +1,6 @@ ;;; inline.el --- Define functions by their inliner -*- lexical-binding:t; -*- -;; Copyright (C) 2014-2015 Free Software Foundation, Inc. +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> @@ -102,7 +102,7 @@ VARS should be a list of elements of the form (VAR EXP) or just VAR, in case EXP is equal to VAR. The result is to evaluate EXP and bind the result to VAR. The tail of VARS can be either nil or a symbol VAR which should hold a list -of arguments,in which case each argument is evaluated and the resulting +of arguments, in which case each argument is evaluated and the resulting new list is re-bound to VAR. After VARS is handled, BODY is evaluated in the new environment." diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index ca7a904a087..d7069174c1b 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -1,14 +1,17 @@ ;;; let-alist.el --- Easily let-bind values of an assoc-list by their names -*- lexical-binding: t; -*- -;; Copyright (C) 2014-2015 Free Software Foundation, Inc. +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. -;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com> +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Package-Requires: ((emacs "24.1")) ;; Version: 1.0.4 ;; Keywords: extensions lisp ;; Prefix: let-alist ;; Separator: - +;; This is an Elpa :core package. Don't use functionality that is not +;; compatible with Emacs 24.1. + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -73,6 +76,11 @@ symbol, and each cdr is the same symbol without the `.'." ;; with other results in the clause below. (list (cons data (intern (replace-match "" nil nil name))))))) ((not (consp data)) nil) + ((eq (car data) 'let-alist) + ;; For nested ‘let-alist’ forms, ignore symbols appearing in the + ;; inner body because they don’t refer to the alist currently + ;; being processed. See Bug#24641. + (let-alist--deep-dot-search (cadr data))) (t (append (let-alist--deep-dot-search (car data)) (let-alist--deep-dot-search (cdr data)))))) @@ -117,10 +125,10 @@ For instance, the following code essentially expands to - (let ((.title (cdr (assq 'title alist))) - (.body (cdr (assq 'body alist))) - (.site (cdr (assq 'site alist))) - (.site.contents (cdr (assq 'contents (cdr (assq 'site alist)))))) + (let ((.title (cdr (assq \\='title alist))) + (.body (cdr (assq \\='body alist))) + (.site (cdr (assq \\='site alist))) + (.site.contents (cdr (assq \\='contents (cdr (assq \\='site alist)))))) (if (and .title .body) .body .site @@ -134,7 +142,7 @@ displayed in the example above." (let ((var (make-symbol "alist"))) `(let ((,var ,alist)) (let ,(mapcar (lambda (x) `(,(car x) ,(let-alist--access-sexp (car x) var))) - (delete-dups (let-alist--deep-dot-search body))) + (delete-dups (let-alist--deep-dot-search body))) ,@body)))) (provide 'let-alist) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 393f0dd99e8..46373da5eb9 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,6 +1,6 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000-2015 Free Software Foundation, +;; Copyright (C) 1992, 1994, 1997, 2000-2016 Free Software Foundation, ;; Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> @@ -265,17 +265,16 @@ a section." (defun lm-header (header) "Return the contents of the header named HEADER." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) - ;; RCS ident likes format "$identifier: data$" - (looking-at - (if (save-excursion - (skip-chars-backward "^$" (match-beginning 0)) - (= (point) (match-beginning 0))) - "[^\n]+" "[^$\n]+"))) - (match-string-no-properties 0))))) + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) + ;; RCS ident likes format "$identifier: data$" + (looking-at + (if (save-excursion + (skip-chars-backward "^$" (match-beginning 0)) + (= (point) (match-beginning 0))) + "[^\n]+" "[^$\n]+"))) + (match-string-no-properties 0)))) (defun lm-header-multiline (header) "Return the contents of the header named HEADER, with continuation lines. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 9ce0dfd49e8..a277d7a6680 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,6 +1,6 @@ ;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1999-2015 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1999-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, languages @@ -58,7 +58,7 @@ (setq i (1+ i))) (modify-syntax-entry ?\s " " table) ;; Non-break space acts as whitespace. - (modify-syntax-entry ?\x8a0 " " table) + (modify-syntax-entry ?\xa0 " " table) (modify-syntax-entry ?\t " " table) (modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\n "> " table) @@ -106,8 +106,10 @@ "define-global-minor-mode" "define-globalized-minor-mode" "define-derived-mode" "define-generic-mode" + "ert-deftest" "cl-defun" "cl-defsubst" "cl-defmacro" - "cl-define-compiler-macro" + "cl-define-compiler-macro" "cl-defgeneric" + "cl-defmethod" ;; CL. "define-compiler-macro" "define-modify-macro" "defsetf" "define-setf-expander" @@ -129,9 +131,10 @@ t)) "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) - ;; For `defvar', we ignore (defvar FOO) constructs. + ;; For `defvar'/`defvar-local', we ignore (defvar FOO) constructs. (list (purecopy "Variables") - (purecopy (concat "^\\s-*(defvar\\s-+\\(" lisp-mode-symbol-regexp "\\)" + (purecopy (concat "^\\s-*(defvar\\(?:-local\\)?\\s-+\\(" + lisp-mode-symbol-regexp "\\)" "[[:space:]\n]+[^)]")) 1) (list (purecopy "Types") @@ -165,6 +168,8 @@ (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") +(defconst lisp-prettify-symbols-alist '(("lambda" . ?λ)) + "Alist of symbol/\"pretty\" characters to be displayed.") ;;;; Font-lock support. @@ -270,7 +275,7 @@ This will generate compile-time constants from BINDINGS." "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" "define-globalized-minor-mode" "define-skeleton" - "define-widget")) + "define-widget" "ert-deftest")) (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" "defface")) (el-tdefs '("defgroup" "deftheme")) @@ -381,7 +386,8 @@ This will generate compile-time constants from BINDINGS." ((eq type 'type) font-lock-type-face) ((or (not (match-string 2)) ;; Normal defun. (and (match-string 2) ;; Setf function. - (match-string 4))) font-lock-function-name-face))) + (match-string 4))) + font-lock-function-name-face))) nil t))) "Subdued level highlighting for Lisp modes.") @@ -392,6 +398,9 @@ This will generate compile-time constants from BINDINGS." lisp-el-font-lock-keywords-1 `( ;; Regexp negated char group. ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Erroneous structures. + (,(concat "(" el-errs-re "\\_>") + (1 font-lock-warning-face)) ;; Control structures. Common Lisp forms. (lisp--el-match-keyword . 1) ;; Exit/Feature symbols as constants. @@ -399,14 +408,11 @@ This will generate compile-time constants from BINDINGS." "[ \t']*\\(" lisp-mode-symbol-regexp "\\)?") (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) - ;; Erroneous structures. - (,(concat "(" el-errs-re "\\_>") - (1 font-lock-warning-face)) ;; Words inside \\[] tend to be for `substitute-command-keys'. (,(concat "\\\\\\\\\\[\\(" lisp-mode-symbol-regexp "\\)\\]") (1 font-lock-constant-face prepend)) - ;; Words inside ‘’ and '' and `' tend to be symbol names. - (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + ;; Words inside ‘’ and `' tend to be symbol names. + (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) ;; Constant values. @@ -457,8 +463,8 @@ This will generate compile-time constants from BINDINGS." ;; Erroneous structures. (,(concat "(" cl-errs-re "\\_>") (1 font-lock-warning-face)) - ;; Words inside ‘’ and '' and `' tend to be symbol names. - (,(concat "['`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" + ;; Words inside ‘’ and `' tend to be symbol names. + (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) ;; Constant values. @@ -486,6 +492,9 @@ This will generate compile-time constants from BINDINGS." "Default expressions to highlight in Lisp modes.") (defun lisp-string-in-doc-position-p (listbeg startpos) + "Return true if a doc string may occur at STARTPOS inside a list. +LISTBEG is the position of the start of the innermost list +containing STARTPOS." (let* ((firstsym (and listbeg (save-excursion (goto-char listbeg) @@ -516,6 +525,9 @@ This will generate compile-time constants from BINDINGS." (= (point) startpos)))))) (defun lisp-string-after-doc-keyword-p (listbeg startpos) + "Return true if `:documentation' symbol ends at STARTPOS inside a list. +LISTBEG is the position of the start of the innermost list +containing STARTPOS." (and listbeg ; We are inside a Lisp form. (save-excursion (goto-char startpos) @@ -524,6 +536,9 @@ This will generate compile-time constants from BINDINGS." (looking-at ":documentation\\_>")))))) (defun lisp-font-lock-syntactic-face-function (state) + "Return syntactic face function for the position represented by STATE. +STATE is a `parse-partial-sexp' state, and the returned function is the +Lisp font lock syntactic face function." (if (nth 3 state) ;; This might be a (doc)string or a |...| symbol. (let ((startpos (nth 8 state))) @@ -581,7 +596,7 @@ font-lock keywords will not be case sensitive." (font-lock-extra-managed-props help-echo) (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function))) - (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) + (setq-local prettify-symbols-alist lisp-prettify-symbols-alist) (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) @@ -642,9 +657,6 @@ font-lock keywords will not be case sensitive." :type 'hook :group 'lisp) -(defconst lisp--prettify-symbols-alist - '(("lambda" . ?λ))) - ;;; Generic Lisp mode. (defvar lisp-mode-map @@ -1204,8 +1216,15 @@ and initial semicolons." ;; ;; The `fill-column' is temporarily bound to ;; `emacs-lisp-docstring-fill-column' if that value is an integer. - (let ((paragraph-start (concat paragraph-start - "\\|\\s-*\\([(;:\"]\\|`(\\|#'(\\)")) + (let ((paragraph-start + (concat paragraph-start + (format "\\|\\s-*\\([(;%s\"]\\|`(\\|#'(\\)" + ;; If we're inside a string (like the doc + ;; string), don't consider a colon to be + ;; a paragraph-start character. + (if (nth 3 (syntax-ppss)) + "" + ":")))) (paragraph-separate (concat paragraph-separate "\\|\\s-*\".*[,\\.]$")) (fill-column (if (and (integerp emacs-lisp-docstring-fill-column) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index ca977db4b1d..ea7cce67be7 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,6 +1,6 @@ ;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1994, 2000-2015 Free Software Foundation, +;; Copyright (C) 1985-1986, 1994, 2000-2016 Free Software Foundation, ;; Inc. ;; Maintainer: emacs-devel@gnu.org @@ -587,7 +587,11 @@ Interactively, the behavior depends on `narrow-to-defun-include-comments'." Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR OPEN-CHAR CLOSE-CHAR). The characters OPEN-CHAR and CLOSE-CHAR of the pair whose key is equal to the last input character with -or without modifiers, are inserted by `insert-pair'.") +or without modifiers, are inserted by `insert-pair'. + +If COMMAND-CHAR is specified, it is a character that triggers the +insertion of the open/close pair, and COMMAND-CHAR itself isn't +inserted.") (defun insert-pair (&optional arg open close) "Enclose following ARG sexps in a pair of OPEN and CLOSE characters. @@ -618,8 +622,11 @@ This command assumes point is not in a string or comment." (if (and open close) (if (and transient-mark-mode mark-active) (progn - (save-excursion (goto-char (region-end)) (insert close)) - (save-excursion (goto-char (region-beginning)) (insert open))) + (save-excursion + (goto-char (region-end)) + (insert close)) + (goto-char (region-beginning)) + (insert open)) (if arg (setq arg (prefix-numeric-value arg)) (setq arg 0)) (cond ((> arg 0) (skip-chars-forward " \t")) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 8983454d318..6d89145c6a2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; -;; Copyright (C) 2004-2015 Free Software Foundation, Inc. +;; Copyright (C) 2004-2016 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -103,7 +103,7 @@ each clause." (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. The purpose is to delay warnings to bytecomp.el, so they can use things -like `byte-compile-log-warning' to get better file-and-line-number data +like `byte-compile-warn' to get better file-and-line-number data and also to avoid outputting the warning during normal execution." nil) (put 'macroexp--funcall-if-compiled 'byte-compile @@ -122,7 +122,7 @@ and also to avoid outputting the warning during normal execution." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) (defun macroexp--warn-and-return (msg form &optional compile-only) - (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) + (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) (cond ((null msg) form) ((macroexp--compiling-p) @@ -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-ynp.el b/lisp/emacs-lisp/map-ynp.el index b8fb540d6cb..86057706ffc 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -1,6 +1,6 @@ ;;; map-ynp.el --- general-purpose boolean question-asker -*- lexical-binding:t -*- -;; Copyright (C) 1991-1995, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2016 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 5ef51f12d96..0a0f64a0761 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -1,10 +1,10 @@ ;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*- -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; 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,22 +43,24 @@ ;;; Code: (require 'seq) +(eval-when-compile (require 'cl-lib)) (pcase-defmacro map (&rest args) "Build a `pcase' pattern matching map elements. -The `pcase' pattern will match each element of PATTERN against -the corresponding elements of the map. +ARGS is a list of elements to be matched in the map. -Extra elements of the map are ignored if fewer ARGS are -given, and the match does not fail. +Each element of ARGS can be of the form (KEY PAT), in which case KEY is +evaluated and searched for in the map. The match fails if for any KEY +found in the map, the corresponding PAT doesn't match the value +associated to the KEY. -ARGS can be a list of the form (KEY PAT), in which case KEY in an -unquoted form. +Each element can also be a SYMBOL, which is an abbreviation of a (KEY +PAT) tuple of the form (\\='SYMBOL SYMBOL). -ARGS can also be a list of symbols, which stands for ('SYMBOL -SYMBOL)." - `(and (pred map-p) +Keys in ARGS not found in the map are ignored, and the match doesn't +fail." + `(and (pred mapp) ,@(map--make-pcase-bindings args))) (defmacro map-let (keys map &rest body) @@ -77,14 +79,14 @@ MAP can be a list, hash-table or array." (eval-when-compile (defmacro map--dispatch (map-var &rest args) - "Evaluate one of the forms specified by ARGS based on the type of MAP. + "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR. The following keyword types are meaningful: `:list', `:hash-table' and `:array'. -An error is thrown if MAP is neither a list, hash-table nor array. +An error is thrown if MAP-VAR is neither a list, hash-table nor array. -Return RESULT if non-nil or the result of evaluation of the form." +Returns the result of evaluating the form associated with MAP-VAR's type." (declare (debug t) (indent 1)) `(cond ((listp ,map-var) ,(plist-get args :list)) ((hash-table-p ,map-var) ,(plist-get args :hash-table)) @@ -122,40 +124,33 @@ MAP can be a list, hash-table or array." default))) (defmacro map-put (map key value) - "Associate KEY with VALUE in MAP and return MAP. + "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. MAP can be a list, hash-table or array." - (macroexp-let2 nil map map - `(progn - (setf (map-elt ,map ,key) ,value) - ,map))) + `(setf (map-elt ,map ,key) ,value)) -(defmacro map-delete (map key) +(defun map-delete (map key) "Delete KEY from MAP and return MAP. No error is signaled if KEY is not a key of MAP. If MAP is an array, store nil at the index KEY. MAP can be a list, hash-table or array." - (declare (debug t)) - (gv-letplace (mgetter msetter) `(gv-delay-error ,map) - (macroexp-let2 nil key key - `(if (not (listp ,mgetter)) - (map--delete ,mgetter ,key) - ;; The alist case is special, since it can't be handled by the - ;; map--delete function. - (setf (alist-get ,key (gv-synthetic-place ,mgetter ,msetter) - nil t) - nil) - ,mgetter)))) + (map--dispatch map + :list (setf (alist-get key map nil t) nil) + :hash-table (remhash key map) + :array (and (>= key 0) + (<= key (seq-length map)) + (aset map key nil))) + map) (defun map-nested-elt (map keys &optional default) "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. Map can be a nested map composed of alists, hash-tables and arrays." (or (seq-reduce (lambda (acc key) - (when (map-p acc) + (when (mapp acc) (map-elt acc key))) keys map) @@ -206,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. @@ -239,7 +244,7 @@ MAP can be a list, hash-table or array." (map-filter (lambda (key val) (not (funcall pred key val))) map)) -(defun map-p (map) +(defun mapp (map) "Return non-nil if MAP is a map (list, hash-table or array)." (or (listp map) (hash-table-p map) @@ -255,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." @@ -279,21 +284,42 @@ MAP can be a list, hash-table or array." MAP can be a list, hash-table or array." (catch 'map--break (map-apply (lambda (key value) - (or (funcall pred key value) - (throw 'map--break nil))) - map) + (or (funcall pred key value) + (throw 'map--break nil))) + map) t)) (defun map-merge (type &rest maps) "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))) + 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 (map-into (pop maps) type)) + (not-found (cons nil nil))) + (while maps + (map-apply (lambda (key value) + (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. @@ -321,15 +347,6 @@ MAP can be a list, hash-table or array." (cdr pair))) map)) -(defun map--delete (map key) - (map--dispatch map - :list (error "No place to remove the mapping for %S" key) - :hash-table (remhash key map) - :array (and (>= key 0) - (<= key (seq-length map)) - (aset map key nil))) - map) - (defun map--apply-hash-table (function map) "Private function used to apply FUNCTION over MAP, MAP being a hash-table." (let (result) @@ -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 2cd34e12810..1b30499bf19 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -1,6 +1,6 @@ ;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*- -;; Copyright (C) 2012-2015 Free Software Foundation, Inc. +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions, lisp, tools @@ -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)))) @@ -279,7 +282,7 @@ a special meaning: whereas a depth of -100 means that the advice should be outermost. If PLACE is a symbol, its `default-value' will be affected. -Use (local 'SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. +Use (local \\='SYMBOL) if you want to apply FUNCTION to SYMBOL buffer-locally. Use (var VAR) if you want to apply FUNCTION to the (lexical) VAR. If one of FUNCTION or OLDFUN is interactive, then the resulting function @@ -289,7 +292,10 @@ is also interactive. There are 3 cases: argument (the interactive spec of OLDFUN, which it can pass to `advice-eval-interactive-spec') and return the list of arguments to use. - Else, use the interactive spec of FUNCTION and ignore the one of OLDFUN." - (declare (debug t)) ;;(indent 2) + (declare + ;;(indent 2) + (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] + form &optional form))) `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) ,function ,props)) @@ -311,7 +317,8 @@ is also interactive. There are 3 cases: If FUNCTION was not added to PLACE, do nothing. Instead of FUNCTION being the actual function, it can also be the `name' of the piece of advice." - (declare (debug t)) + (declare (debug ([&or symbolp ("local" form) ("var" sexp) gv-place] + form))) (gv-letplace (getter setter) (advice--normalize-place place) (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 81d0b834722..32070dba418 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,6 +1,6 @@ ;;; package-x.el --- Package extras -;; Copyright (C) 2007-2015 Free Software Foundation, Inc. +;; Copyright (C) 2007-2016 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Created: 10 Mar 2007 diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2962da5a917..ef129e998c2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,11 +1,11 @@ ;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 2007-2015 Free Software Foundation, Inc. +;; Copyright (C) 2007-2016 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> ;; Daniel Hackney <dan@haxney.org> ;; Created: 10 Mar 2007 -;; Version: 1.0.1 +;; Version: 1.1.0 ;; Keywords: tools ;; Package-Requires: ((tabulated-list "1.0")) @@ -24,14 +24,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. -;;; Change Log: - -;; 2 Apr 2007 - now using ChangeLog file -;; 15 Mar 2007 - updated documentation -;; 14 Mar 2007 - Changed how obsolete packages are handled -;; 13 Mar 2007 - Wrote package-install-from-buffer -;; 12 Mar 2007 - Wrote package-menu mode - ;;; Commentary: ;; The idea behind package.el is to be able to download packages and @@ -69,6 +61,7 @@ ;; * Download. Fetching the package from ELPA. ;; * Install. Untar the package, or write the .el file, into ;; ~/.emacs.d/elpa/ directory. +;; * Autoload generation. ;; * Byte compile. Currently this phase is done during install, ;; but we may change this. ;; * Activate. Evaluate the autoloads for the package to make it @@ -127,14 +120,9 @@ ;; - "installed" instead of a blank in the status column ;; - tramp needs its files to be compiled in a certain order. ;; how to handle this? fix tramp? -;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22? ;; - maybe we need separate .elc directories for various emacs versions ;; and also emacs-vs-xemacs. That way conditional compilation can ;; work. But would this break anything? -;; - should store the package's keywords in archive-contents, then -;; let the users filter the package-menu by keyword. See -;; finder-by-keyword. (We could also let people view the -;; Commentary, but it isn't clear how useful this is.) ;; - William Xu suggests being able to open a package file without ;; installing it ;; - Interface with desktop.el so that restarting after an install @@ -145,15 +133,9 @@ ;; private data dir, aka ".../etc". Or, maybe data-directory ;; needs to be a list (though this would be less nice) ;; a few packages want this, eg sokoban -;; - package menu needs: -;; ability to know which packages are built-in & thus not deletable -;; it can sometimes print odd results, like 0.3 available but 0.4 active -;; why is that? -;; - Allow multiple versions on the server...? -;; [ why bother? ] -;; - Don't install a package which will invalidate dependencies overall -;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5)) -;; [ currently thinking, why bother.. KISS ] +;; - Allow multiple versions on the server, so that if a user doesn't +;; meet the requirements for the most recent version they can still +;; install an older one. ;; - Allow optional package dependencies ;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb ;; and just don't compile to add to load path ...? @@ -164,9 +146,11 @@ (eval-when-compile (require 'subr-x)) (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'epg)) ;For setf accessors. +(require 'seq) (require 'tabulated-list) (require 'macroexp) +(require 'url-handlers) (defgroup package nil "Manager for Emacs Lisp packages." @@ -200,7 +184,13 @@ If VERSION is a string, only that version is ever loaded. Any other version, even if newer, is silently ignored. Hence, the package is \"held\" at that version. If VERSION is nil, the package is not loaded (it is \"disabled\")." - :type '(repeat symbol) + :type '(repeat (choice (const all) + (list :tag "Specific package" + (symbol :tag "Package name") + (choice :tag "Version" + (const :tag "disable" nil) + (const :tag "most recent" t) + (string :tag "specific version"))))) :risky t :version "24.1") @@ -234,7 +224,7 @@ of it available such that: This variable has three possible values: nil: no packages are hidden; - `archive': only criteria (a) is used; + `archive': only criterion (a) is used; t: both criteria are used. This variable has no effect if `package-menu--hide-packages' is @@ -252,7 +242,7 @@ Each element has the form (ARCHIVE-ID . PRIORITY). When installing packages, the package with the highest version number from the archive with the highest priority is -selected. When higher versions are available from archives with +selected. When higher versions are available from archives with lower priorities, the user has to select those manually. Archives not in this list have the priority 0. @@ -312,10 +302,12 @@ contrast, `package-user-dir' contains packages for personal use." :risky t :version "24.1") -(defvar epg-gpg-program) +(declare-function epg-find-configuration "epg-config" + (protocol &optional no-cache program-alist)) (defcustom package-check-signature - (if (progn (require 'epg-config) (executable-find epg-gpg-program)) + (if (and (require 'epg-config) + (epg-find-configuration 'OpenPGP)) 'allow-unsigned) "Non-nil means to check package signatures when installing. The value `allow-unsigned' means to still install a package even if @@ -346,6 +338,7 @@ by running `package-install-selected-packages'. To check if a package is contained in this list here, use `package--user-selected-p', as it may populate the variable with a sane initial value." + :version "25.1" :type '(repeat symbol)) (defcustom package-menu-async t @@ -664,8 +657,30 @@ PKG-DESC is a `package-desc' object." (defvar Info-directory-list) (declare-function info-initialize "info" ()) -(defun package-activate-1 (pkg-desc &optional reload) +(defun package--load-files-for-activation (pkg-desc reload) + "Load files for activating a package given by PKG-DESC. +Load the autoloads file, and ensure `load-path' is setup. If +RELOAD is non-nil, also load all files in the package that +correspond to previously loaded files." + (let* ((loaded-files-list (when reload + (package--list-loaded-files (package-desc-dir pkg-desc))))) + ;; Add to load path, add autoloads, and activate the package. + (package--activate-autoloads-and-load-path pkg-desc) + ;; Call `load' on all files in `package-desc-dir' already present in + ;; `load-history'. This is done so that macros in these files are updated + ;; to their new definitions. If another package is being installed which + ;; depends on this new definition, not doing this update would cause + ;; compilation errors and break the installation. + (with-demoted-errors "Error in package--load-files-for-activation: %s" + (mapc (lambda (feature) (load feature nil t)) + ;; Skip autoloads file since we already evaluated it above. + (remove (file-truename (package--autoloads-file-name pkg-desc)) + loaded-files-list))))) + +(defun package-activate-1 (pkg-desc &optional reload deps) "Activate package given by PKG-DESC, even if it was already active. +If DEPS is non-nil, also activate its dependencies (unless they +are already activated). If RELOAD is non-nil, also `load' any files inside the package which correspond to previously loaded files (those returned by `package--list-loaded-files')." @@ -674,20 +689,15 @@ correspond to previously loaded files (those returned by (unless pkg-dir (error "Internal error: unable to find directory for `%s'" (package-desc-full-name pkg-desc))) - (let* ((loaded-files-list (when reload - (package--list-loaded-files pkg-dir)))) - ;; Add to load path, add autoloads, and activate the package. - (package--activate-autoloads-and-load-path pkg-desc) - ;; Call `load' on all files in `pkg-dir' already present in - ;; `load-history'. This is done so that macros in these files are updated - ;; to their new definitions. If another package is being installed which - ;; depends on this new definition, not doing this update would cause - ;; compilation errors and break the installation. - (with-demoted-errors "Error in package-activate-1: %s" - (mapc (lambda (feature) (load feature nil t)) - ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename (package--autoloads-file-name pkg-desc)) - loaded-files-list)))) + ;; Activate its dependencies recursively. + ;; FIXME: This doesn't check whether the activated version is the + ;; required version. + (when deps + (dolist (req (package-desc-reqs pkg-desc)) + (unless (package-activate (car req)) + (error "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable" + name (car req) (package-version-join (cadr req)))))) + (package--load-files-for-activation pkg-desc reload) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -739,7 +749,7 @@ DIR, sorted by most recently loaded last." ;; one was already activated. It also loads a features of this ;; package which were already loaded. (defun package-activate (package &optional force) - "Activate package PACKAGE. + "Activate the package named PACKAGE. If FORCE is true, (re-)activate it if it's already activated. Newer versions are always activated, regardless of FORCE." (let ((pkg-descs (cdr (assq package package-alist)))) @@ -759,19 +769,7 @@ Newer versions are always activated, regardless of FORCE." ((and (memq package package-activated-list) (not force)) t) ;; Otherwise, proceed with activation. - (t - (let* ((pkg-vec (car pkg-descs)) - (fail (catch 'dep-failure - ;; Activate its dependencies recursively. - (dolist (req (package-desc-reqs pkg-vec)) - (unless (package-activate (car req)) - (throw 'dep-failure req)))))) - (if fail - (warn "Unable to activate package `%s'. -Required package `%s-%s' is unavailable" - package (car fail) (package-version-join (cadr fail))) - ;; If all goes well, activate the package itself. - (package-activate-1 pkg-vec force))))))) + (t (package-activate-1 (car pkg-descs) nil 'deps))))) ;;; Installation -- Local operations @@ -794,7 +792,7 @@ untar into a directory named DIR; otherwise, signal an error." (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) - (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) + (case-fold-search (file-name-case-insensitive-p dir))) (dolist (tar-data tar-parse-info) (let ((name (expand-file-name (tar-header-name tar-data)))) (or (string-match regexp name) @@ -842,13 +840,21 @@ untar into a directory named DIR; otherwise, signal an error." (package--make-autoloads-and-stuff pkg-desc pkg-dir) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) - ;; FIXME: Check that `new-desc' matches `desc'! + (unless (equal (package-desc-full-name new-desc) + (package-desc-full-name pkg-desc)) + (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')" + (package-desc-full-name new-desc) (package-desc-full-name pkg-desc))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (package-activate-1 new-desc :reload :deps) ;; FIXME: Compilation should be done as a separate, optional, step. ;; E.g. for multi-package installs, we should first install all packages ;; and then compile them. - (package--compile new-desc)) - ;; Try to activate it. - (package-activate name 'force) + (package--compile new-desc) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--load-files-for-activation new-desc :reload)) pkg-dir)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -902,12 +908,15 @@ untar into a directory named DIR; otherwise, signal an error." file) (defvar generated-autoload-file) +(defvar autoload-timestamps) (defvar version-control) (defun package-generate-autoloads (name pkg-dir) (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) + ;; We don't need 'em, and this makes the output reproducible. + (autoload-timestamps nil) ;; Silence `autoload-generate-file-autoloads'. (noninteractive inhibit-message) (backup-inhibited t) @@ -931,11 +940,12 @@ untar into a directory named DIR; otherwise, signal an error." ;;;; Compilation (defvar warning-minimum-level) (defun package--compile (pkg-desc) - "Byte-compile installed package PKG-DESC." + "Byte-compile installed package PKG-DESC. +This assumes that `pkg-desc' has already been activated with +`package-activate-1'." (let ((warning-minimum-level :error) (save-silently inhibit-message) (load-path load-path)) - (package--activate-autoloads-and-load-path pkg-desc) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) ;;;; Inferring package from current buffer @@ -1071,6 +1081,8 @@ The return result is a `package-desc'." (setq files nil) ;; set the 'dir kind, (setf (package-desc-kind info) 'dir)))) + (unless info + (error "No .el files with package headers in `%s'" default-directory)) ;; and return the info. info)))) @@ -1124,7 +1136,8 @@ FILE is the name of a file relative to that base location. This macro retrieves FILE from LOCATION into a temporary buffer, and evaluates BODY while that buffer is current. This work buffer is killed afterwards. Return the last value in BODY." - (declare (indent 2) (debug t)) + (declare (indent 2) (debug t) + (obsolete package--with-response-buffer "25.1")) `(with-temp-buffer (if (string-match-p "\\`https?:" ,location) (url-insert-file-contents (concat ,location ,file)) @@ -1134,47 +1147,61 @@ buffer is killed afterwards. Return the last value in BODY." (insert-file-contents (expand-file-name ,file ,location))) ,@body)) -(defmacro package--with-work-buffer-async (location file async &rest body) - "Run BODY in a buffer containing the contents of FILE at LOCATION. -If ASYNC is non-nil, and if it is possible, run BODY -asynchronously. If an error is encountered and ASYNC is a -function, call it with no arguments (instead of executing BODY). -If it returns non-nil, or if it wasn't a function, propagate the -error. - -For a description of the other arguments see -`package--with-work-buffer'." - (declare (indent 3) (debug t)) - (macroexp-let2* macroexp-copyable-p - ((async-1 async) - (file-1 file) - (location-1 location)) - `(if (or (not ,async-1) - (not (string-match-p "\\`https?:" ,location-1))) - (package--with-work-buffer ,location-1 ,file-1 ,@body) - ;; This `condition-case' is to catch connection errors. - (condition-case error-signal - (url-retrieve (concat ,location-1 ,file-1) - ;; This is to catch execution errors. - (lambda (status) - (condition-case error-signal - (progn - (when-let ((er (plist-get status :error))) - (error "Error retrieving: %s %S" (concat ,location-1 ,file-1) er)) - (goto-char (point-min)) - (unless (search-forward "\n\n" nil 'noerror) - (error "Invalid url response in buffer %s" - (current-buffer))) - (delete-region (point-min) (point)) - ,@body - (kill-buffer (current-buffer))) - (error (when (if (functionp ,async-1) (funcall ,async-1) t) - (signal (car error-signal) (cdr error-signal)))))) - nil - 'silent) - (error (when (if (functionp ,async-1) (funcall ,async-1) t) - (message "Error contacting: %s" (concat ,location-1 ,file-1)) - (signal (car error-signal) (cdr error-signal)))))))) +(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys) + "Access URL and run BODY in a buffer containing the response. +Point is after the headers when BODY runs. +FILE, if provided, is added to URL. +URL can be a local file name, which must be absolute. +ASYNC, if non-nil, runs the request asynchronously. +ERROR-FORM is run only if a connection error occurs. If NOERROR +is non-nil, don't propagate connection errors (does not apply to +errors signaled by ERROR-FORM or by BODY). + +\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)" + (declare (indent defun) (debug t)) + (while (keywordp (car body)) + (setq body (cdr (cdr body)))) + (macroexp-let2* nil ((url-1 url) + (noerror-1 noerror)) + (let ((url-sym (make-symbol "url")) + (b-sym (make-symbol "b-sym"))) + `(cl-macrolet ((unless-error (body-2 &rest before-body) + (let ((err (make-symbol "err"))) + `(with-temp-buffer + (when (condition-case ,err + (progn ,@before-body t) + ,(list 'error ',error-form + (list 'unless ',noerror-1 + `(signal (car ,err) (cdr ,err))))) + ,@body-2))))) + (if (string-match-p "\\`https?:" ,url-1) + (let ((,url-sym (concat ,url-1 ,file))) + (if ,async + (unless-error nil + (url-retrieve ,url-sym + (lambda (status) + (let ((,b-sym (current-buffer))) + (require 'url-handlers) + (unless-error ,body + (when-let ((er (plist-get status :error))) + (error "Error retrieving: %s %S" ,url-sym er)) + (with-current-buffer ,b-sym + (goto-char (point-min)) + (unless (search-forward-regexp "^\r?\n\r?" nil 'noerror) + (error "Error retrieving: %s %S" ,url-sym "incomprehensible buffer"))) + (url-insert-buffer-contents ,b-sym ,url-sym) + (kill-buffer ,b-sym) + (goto-char (point-min))))) + nil + 'silent)) + (unless-error ,body (url-insert-file-contents ,url-sym)))) + (unless-error ,body + (let ((url (expand-file-name ,file ,url-1))) + (unless (file-name-absolute-p url) + (error "Location %s is not a url nor an absolute file name" url)) + (insert-file-contents url)))))))) + +(define-error 'bad-signature "Failed to verify signature") (defun package--check-signature-content (content string &optional sig-file) "Check signature CONTENT against STRING. @@ -1186,7 +1213,7 @@ errors." (condition-case error (epg-verify-string context content string) (error (package--display-verify-error context sig-file) - (signal (car error) (cdr error)))) + (signal 'bad-signature error))) (let (good-signatures had-fatal-error) ;; The .sig file may contain multiple signatures. Success if one ;; of the signatures is good. @@ -1200,12 +1227,12 @@ errors." (unless (and (eq package-check-signature 'allow-unsigned) (eq (epg-signature-status sig) 'no-pubkey)) (setq had-fatal-error t)))) - (when (and (null good-signatures) had-fatal-error) + (when (or (null good-signatures) had-fatal-error) (package--display-verify-error context sig-file) - (error "Failed to verify signature %s" sig-file)) + (signal 'bad-signature (list sig-file))) good-signatures))) -(defun package--check-signature (location file &optional string async callback) +(defun package--check-signature (location file &optional string async callback unwind) "Check signature of the current buffer. Download the signature file from LOCATION by appending \".sig\" to FILE. @@ -1214,21 +1241,35 @@ STRING is the string to verify, it defaults to `buffer-string'. If ASYNC is non-nil, the download of the signature file is done asynchronously. -If the signature is verified and CALLBACK was provided, CALLBACK -is `funcall'ed with the list of good signatures as argument (the -list can be empty). If the signatures file is not found, -CALLBACK is called with no arguments." +If the signature does not verify, signal an error. +If the signature is verified and CALLBACK was provided, `funcall' +CALLBACK with the list of good signatures as argument (the list +can be empty). +If no signatures file is found, and `package-check-signature' is +`allow-unsigned', call CALLBACK with a nil argument. +Otherwise, an error is signaled. + +UNWIND, if provided, is a function to be called after everything +else, even if an error is signaled." (let ((sig-file (concat file ".sig")) (string (or string (buffer-string)))) - (condition-case nil - (package--with-work-buffer-async - location sig-file (when async (or callback t)) - (let ((sig (package--check-signature-content - (buffer-string) string sig-file))) + (package--with-response-buffer location :file sig-file + :async async :noerror t + ;; Connection error is assumed to mean "no sig-file". + :error-form (let ((allow-unsigned (eq package-check-signature 'allow-unsigned))) + (when (and callback allow-unsigned) + (funcall callback nil)) + (when unwind (funcall unwind)) + (unless allow-unsigned + (error "Unsigned file `%s' at %s" file location))) + ;; OTOH, an error here means "bad signature", which we never + ;; suppress. (Bug#22089) + (unwind-protect + (let ((sig (package--check-signature-content (buffer-substring (point) (point-max)) + string sig-file))) (when callback (funcall callback sig)) - sig)) - (file-error (funcall callback))))) - + sig) + (when unwind (funcall unwind)))))) ;;; Packages on Archives ;; The following variables store information about packages available @@ -1398,7 +1439,10 @@ If `user-init-file' does not mention `(package-initialize)', add it to the file. If called as part of loading `user-init-file', set `package-enable-at-startup' to nil, to prevent accidentally -loading packages twice." +loading packages twice. +It is not necessary to adjust `load-path' or `require' the +individual packages after calling `package-initialize' -- this is +taken care of by `package-initialize'." (interactive) (setq package-alist nil) (if (equal user-init-file load-file-name) @@ -1425,9 +1469,6 @@ loading packages twice." (defvar package--downloads-in-progress nil "List of in-progress asynchronous downloads.") -(declare-function epg-check-configuration "epg-config" - (config &optional minimum-version)) -(declare-function epg-configuration "epg-config" ()) (declare-function epg-import-keys-from-file "epg" (context keys)) ;;;###autoload @@ -1470,7 +1511,9 @@ Once it's empty, run `package--post-download-archives-hook'." ARCHIVE should be a cons cell of the form (NAME . LOCATION), similar to an entry in `package-alist'. Save the cached copy to \"archives/NAME/FILE\" in `package-user-dir'." - (package--with-work-buffer-async (cdr archive) file async + (package--with-response-buffer (cdr archive) :file file + :async async + :error-form (package--update-downloads-in-progress archive) (let* ((location (cdr archive)) (name (car archive)) (content (buffer-string)) @@ -1489,22 +1532,12 @@ similar to an entry in `package-alist'. Save the cached copy to location file content async ;; This function will be called after signature checking. (lambda (&optional good-sigs) - (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) - ;; Even if the sig fails, this download is done, so - ;; remove it from the in-progress list. - (package--update-downloads-in-progress archive) - (error "Unsigned archive `%s'" name)) - ;; Write out the archives file. (write-region content nil local-file nil 'silent) ;; Write out good signatures into archive-contents.signed file. (when good-sigs (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") - nil (concat local-file ".signed") nil 'silent)) - (package--update-downloads-in-progress archive) - ;; If we got this far, either everything worked or we don't mind - ;; not signing, so tell `package--with-work-buffer-async' to not - ;; propagate errors. - nil))))))) + nil (concat local-file ".signed") nil 'silent))) + (lambda () (package--update-downloads-in-progress archive)))))))) (defun package--download-and-read-archives (&optional async) "Download descriptions of all `package-archives' and read them. @@ -1517,12 +1550,7 @@ perform the downloads asynchronously." :test #'equal)) (dolist (archive package-archives) (condition-case-unless-debug nil - (package--download-one-archive - archive "archive-contents" - ;; Called if the async download fails - (when async - ;; The t at the end means to propagate connection errors. - (lambda () (package--update-downloads-in-progress archive) t))) + (package--download-one-archive archive "archive-contents" async) (error (message "Failed to download `%s' archive." (car archive)))))) @@ -1542,9 +1570,7 @@ downloads in the background." (inhibit-message async)) (when (and package-check-signature (file-exists-p default-keyring)) (condition-case-unless-debug error - (progn - (epg-check-configuration (epg-configuration)) - (package-import-keyring default-keyring)) + (package-import-keyring default-keyring) (error (message "Cannot import default keyring: %S" (cdr error)))))) (package--download-and-read-archives async)) @@ -1777,7 +1803,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) (package-desc-suffix pkg-desc)))) - (package--with-work-buffer location file + (package--with-response-buffer location :file file (if (or (not package-check-signature) (member (package-desc-archive pkg-desc) package-unsigned-archives)) @@ -1791,11 +1817,6 @@ if all the in-between dependencies are also in PACKAGE-LIST." location file content nil ;; This function will be called after signature checking. (lambda (&optional good-sigs) - (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) - ;; Even if the sig fails, this download is done, so - ;; remove it from the in-progress list. - (error "Unsigned package: `%s'" - (package-desc-name pkg-desc))) ;; Signature checked, unpack now. (with-temp-buffer (insert content) (let ((save-silently t)) @@ -1854,6 +1875,7 @@ add a call to it along with some explanatory comments." (file-readable-p user-init-file) (file-writable-p user-init-file)) (let* ((buffer (find-buffer-visiting user-init-file)) + buffer-name (contains-init (if buffer (with-current-buffer buffer @@ -1869,8 +1891,12 @@ add a call to it along with some explanatory comments." (re-search-forward "(package-initialize\\_>" nil 'noerror))))) (unless contains-init (with-current-buffer (or buffer - (let ((delay-mode-hooks t)) + (let ((delay-mode-hooks t) + (find-file-visit-truename t)) (find-file-noselect user-init-file))) + (when buffer + (setq buffer-name (buffer-file-name)) + (set-visited-file-name (file-chase-links user-init-file))) (save-excursion (save-restriction (widen) @@ -1889,7 +1915,10 @@ add a call to it along with some explanatory comments." (insert "\n")) (let ((file-precious-flag t)) (save-buffer)) - (unless buffer + (if buffer + (progn + (set-visited-file-name buffer-name) + (set-buffer-modified-p nil)) (kill-buffer (current-buffer))))))))) (setq package--init-file-ensured t)) @@ -1973,7 +2002,8 @@ Downloads and installs required packages as needed." ((derived-mode-p 'tar-mode) (package-tar-file-info)) (t - (package-buffer-info)))) + (save-excursion + (package-buffer-info))))) (name (package-desc-name pkg-desc))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) @@ -2011,17 +2041,21 @@ If some packages are not installed propose to install them." ;; gets installed). (if (not package-selected-packages) (message "`package-selected-packages' is empty, nothing to install") - (cl-loop for p in package-selected-packages - unless (package-installed-p p) - collect p into lst - finally - (if lst - (when (y-or-n-p - (format "%s packages will be installed:\n%s, proceed?" - (length lst) - (mapconcat #'symbol-name lst ", "))) - (mapc #'package-install lst)) - (message "All your packages are already installed"))))) + (let* ((not-installed (seq-remove #'package-installed-p package-selected-packages)) + (available (seq-filter (lambda (p) (assq p package-archive-contents)) not-installed)) + (difference (- (length not-installed) (length available)))) + (cond + (available + (when (y-or-n-p + (format "%s packages will be installed:\n%s, proceed?" + (length available) + (mapconcat #'symbol-name available ", "))) + (mapc (lambda (p) (package-install p 'dont-select)) available))) + ((> difference 0) + (message "%s packages are not available (the rest already installed), maybe you need to `M-x package-refresh-contents'" + difference)) + (t + (message "All your packages are already installed")))))) ;;; Package Deletion @@ -2227,13 +2261,13 @@ Otherwise no newline is inserted." (package--print-help-section "Status") (cond (built-in (insert (propertize (capitalize status) - 'font-lock-face 'package-status-builtin-face) + 'font-lock-face 'package-status-built-in) ".")) (pkg-dir (insert (propertize (if (member status '("unsigned" "dependency")) "Installed" (capitalize status)) - 'font-lock-face 'package-status-builtin-face)) + 'font-lock-face 'package-status-built-in)) (insert (substitute-command-keys " in `")) (let ((dir (abbreviate-file-name (file-name-as-directory @@ -2246,7 +2280,7 @@ Otherwise no newline is inserted." (insert (substitute-command-keys "',\n shadowing a ") (propertize "built-in package" - 'font-lock-face 'package-status-builtin-face)) + 'font-lock-face 'package-status-built-in)) (insert (substitute-command-keys "'"))) (if signed (insert ".") @@ -2276,7 +2310,7 @@ Otherwise no newline is inserted." (insert "\n") (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive. (package--print-help-section "Archive" - (or archive "n/a") "\n")) + (or archive "n/a"))) (and version (package--print-help-section "Version" (package-version-join version))) @@ -2368,26 +2402,23 @@ Otherwise no newline is inserted." (replace-match "")) (while (re-search-forward "^\\(;+ ?\\)" nil t) (replace-match "")))) - (let ((readme (expand-file-name (format "%s-readme.txt" name) - package-user-dir)) - readme-string) + (let* ((basename (format "%s-readme.txt" name)) + (readme (expand-file-name basename package-user-dir)) + readme-string) ;; For elpa packages, try downloading the commentary. If that ;; fails, try an existing readme file in `package-user-dir'. - (cond ((condition-case nil - (save-excursion - (package--with-work-buffer - (package-archive-base desc) - (format "%s-readme.txt" name) - (save-excursion - (goto-char (point-max)) - (unless (bolp) - (insert ?\n))) - (write-region nil nil - (expand-file-name readme package-user-dir) - nil 'silent) - (setq readme-string (buffer-string)) - t)) - (error nil)) + (cond ((and (package-desc-archive desc) + (package--with-response-buffer (package-archive-base desc) + :file basename :noerror t + (save-excursion + (goto-char (point-max)) + (unless (bolp) + (insert ?\n))) + (write-region nil nil + (expand-file-name readme package-user-dir) + nil 'silent) + (setq readme-string (buffer-string)) + t)) (insert readme-string)) ((file-readable-p readme) (insert-file-contents readme) @@ -2654,6 +2685,7 @@ omitted from the package menu. To toggle this, type \\[package-menu-toggle-hidi Values can be interactively added to this list by typing \\[package-menu-hide-package] on a package" + :version "25.1" :type '(repeat (regexp :tag "Hide packages with name matching"))) (defun package-menu--refresh (&optional packages keywords) @@ -2800,13 +2832,14 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." "Face used on package description summaries in the package menu." :version "25.1") +;; Shame this hyphenates "built-in", when "font-lock-builtin-face" doesn't. (defface package-status-built-in '((t :inherit font-lock-builtin-face)) "Face used on the status and version of built-in packages." :version "25.1") (defface package-status-external - '((t :inherit package-status-builtin-face)) + '((t :inherit package-status-built-in)) "Face used on the status and version of external packages." :version "25.1") diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 8bcb447cfbb..896ad925928 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,6 +1,6 @@ ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- -;; Copyright (C) 2010-2015 Free Software Foundation, Inc. +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: @@ -107,38 +107,57 @@ ;;;###autoload (defmacro pcase (exp &rest cases) - "Perform ML-style pattern matching on EXP. + "Evaluate EXP and attempt to match it against structural patterns. CASES is a list of elements of the form (PATTERN CODE...). -Patterns can take the following forms: +A structural PATTERN describes a template that identifies a class +of values. For example, the pattern \\=`(,foo ,bar) matches any +two element list, binding its elements to symbols named `foo' and +`bar' -- in much the same way that `cl-destructuring-bind' would. + +A significant difference from `cl-destructuring-bind' is that, if +a pattern match fails, the next case is tried until either a +successful match is found or there are no more cases. + +Another difference is that pattern elements may be quoted, +meaning they must match exactly: The pattern \\='(foo bar) +matches only against two element lists containing the symbols +`foo' and `bar' in that order. (As a short-hand, atoms always +match themselves, such as numbers or strings, and need not be +quoted.) + +Lastly, a pattern can be logical, such as (pred numberp), that +matches any number-like element; or the symbol `_', that matches +anything. Also, when patterns are backquoted, a comma may be +used to introduce logical patterns inside backquoted patterns. + +The complete list of standard patterns is as follows: + _ matches anything. SYMBOL matches anything and binds it to SYMBOL. + If a SYMBOL is used twice in the same pattern + the second occurrence becomes an `eq'uality test. (or PAT...) matches if any of the patterns matches. (and PAT...) matches if all the patterns match. - \\='VAL matches if the object is `equal' to VAL + \\='VAL matches if the object is `equal' to VAL. ATOM is a shorthand for \\='ATOM. ATOM can be a keyword, an integer, or a string. (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXP) matches if EXP matches PAT. (app FUN PAT) matches if FUN applied to the object matches PAT. -If a SYMBOL is used twice in the same pattern (i.e. the pattern is -\"non-linear\"), then the second occurrence is turned into an `eq'uality test. -FUN can take the form +Additional patterns can be defined using `pcase-defmacro'. + +The FUN argument in the `app' pattern may have the following forms: SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument which is the value being matched. -So a FUN of the form SYMBOL is equivalent to one of the form (FUN). +So a FUN of the form SYMBOL is equivalent to (FUN). FUN can refer to variables bound earlier in the pattern. -FUN is assumed to be pure, i.e. it can be dropped if its result is not used, -and two identical calls can be merged into one. -E.g. you can match pairs where the cdr is larger than the car with a pattern -like \\=`(,a . ,(pred (< a))) or, with more checks: -\\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) - -Additional patterns can be defined via `pcase-defmacro'. -Currently, the following patterns are provided this way:" + +See Info node `(elisp) Pattern matching case statement' in the +Emacs Lisp manual for more information and examples." (declare (indent 1) (debug (form &rest (pcase-PAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time @@ -279,6 +298,8 @@ any kind of error." ;;;###autoload (defmacro pcase-dolist (spec &rest body) + "Like `dolist' but where the binding can be a `pcase' pattern. +\n(fn (PATTERN LIST) BODY...)" (declare (indent 1) (debug ((pcase-PAT form) body))) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) @@ -490,6 +511,7 @@ MATCH is the pattern that needs to be matched, of the form: (numberp . stringp) (numberp . byte-code-function-p) (consp . arrayp) + (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) @@ -865,8 +887,10 @@ Otherwise, it defers to REST which is a list of branches of the form (def-edebug-spec pcase-QPAT + ;; Cf. edebug spec for `backquote-form' in edebug.el. (&or ("," pcase-PAT) - (pcase-QPAT . pcase-QPAT) + (pcase-QPAT [&rest [¬ ","] pcase-QPAT] + . [&or nil pcase-QPAT]) (vector &rest pcase-QPAT) sexp)) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index ac3cc74ca6a..54ea8f3aa34 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,6 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2016 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el new file mode 100644 index 00000000000..8146bb3c283 --- /dev/null +++ b/lisp/emacs-lisp/radix-tree.el @@ -0,0 +1,246 @@ +;;; radix-tree.el --- A simple library of radix trees -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; There are many different options for how to represent radix trees +;; in Elisp. Here I chose a very simple one. A radix-tree can be either: +;; - a node, of the form ((PREFIX . PTREE) . RTREE) where PREFIX is a string +;; meaning that everything that starts with PREFIX is in PTREE, +;; and everything else in RTREE. It also has the property that +;; everything that starts with the first letter of PREFIX but not with +;; that whole PREFIX is not in RTREE (i.e. is not in the tree at all). +;; - anything else is taken as the value to associate with the empty string. +;; So every node is basically an (improper) alist where each mapping applies +;; to a different leading letter. +;; +;; The main downside of this representation is that the lookup operation +;; is slower because each level of the tree is an alist rather than some kind +;; of array, so every level's lookup is O(N) rather than O(1). We could easily +;; solve this by using char-tables instead of alists, but that would make every +;; level take up a lot more memory, and it would make the resulting +;; data structure harder to read (by a human) when printed out. + +;;; Code: + +(defun radix-tree--insert (tree key val i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil key i ni))) + (if (eq t cmp) + (let ((nptree (radix-tree--insert ptree key val ni))) + `((,prefix . ,nptree) . ,rtree)) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (let ((nrtree (radix-tree--insert rtree key val i))) + `((,prefix . ,ptree) . ,nrtree)) + (let* ((nprefix (substring prefix 0 n)) + (kprefix (substring key (+ i n))) + (pprefix (substring prefix n)) + (ktree (if (equal kprefix "") val + `((,kprefix . ,val))))) + `((,nprefix + . ((,pprefix . ,ptree) . ,ktree)) + . ,rtree))))))) + (_ + (if (= (length key) i) val + (let ((prefix (substring key i))) + `((,prefix . ,val) . ,tree)))))) + +(defun radix-tree--remove (tree key i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil key i ni))) + (if (eq t cmp) + (pcase (radix-tree--remove ptree key ni) + (`nil rtree) + (`((,pprefix . ,pptree)) + `((,(concat prefix pprefix) . ,pptree) . ,rtree)) + (nptree `((,prefix . ,nptree) . ,rtree))) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (let ((nrtree (radix-tree--remove rtree key i))) + `((,prefix . ,ptree) . ,nrtree)) + tree))))) + (_ + (if (= (length key) i) nil tree)))) + + +(defun radix-tree--lookup (tree string i) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni))) + (if (eq t cmp) + (radix-tree--lookup ptree string ni) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (if (zerop n) + (radix-tree--lookup rtree string i) + (+ i n)))))) + (val + (if (and val (equal (length string) i)) + (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 + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni))) + (if (eq t cmp) + (radix-tree--subtree ptree string ni) + (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) + (cond + ((zerop n) (radix-tree--subtree rtree string i)) + ((equal (+ n i) (length string)) + (let ((nprefix (substring prefix n))) + `((,nprefix . ,ptree)))) + (t nil)))))) + (_ nil)))) + +;;; Entry points + +(defconst radix-tree-empty nil + "The empty radix-tree.") + +(defun radix-tree-insert (tree key val) + "Insert a mapping from KEY to VAL in radix TREE." + (when (consp val) (setq val `(t . ,val))) + (if val (radix-tree--insert tree key val 0) + (radix-tree--remove tree key 0))) + +(defun radix-tree-lookup (tree key) + "Return the value associated to KEY in radix TREE. +If not found, return nil." + (pcase (radix-tree--lookup tree key 0) + (`(t . ,val) val) + ((pred numberp) nil) + (val val))) + +(defun radix-tree-subtree (tree string) + "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 + ;; doesn't support it. Using `atom' works but generates sub-optimal code. + `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + +(defun radix-tree-iter-subtrees (tree fun) + "Apply FUN to every immediate subtree of radix TREE. +FUN is called with two arguments: PREFIX and SUBTREE. +You can test if SUBTREE is a leaf (and extract its value) with the +pcase pattern (radix-tree-leaf PAT)." + (while tree + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (funcall fun prefix ptree) + (setq tree rtree)) + (_ (funcall fun "" tree) + (setq tree nil))))) + +(defun radix-tree-iter-mappings (tree fun &optional prefix) + "Apply FUN to every mapping in TREE. +FUN is called with two arguments: KEY and VAL. +PREFIX is only used internally." + (radix-tree-iter-subtrees + tree + (lambda (p s) + (let ((nprefix (concat prefix p))) + (pcase s + ((radix-tree-leaf v) (funcall fun nprefix v)) + (_ (radix-tree-iter-mappings s fun nprefix))))))) + +;; (defun radix-tree->alist (tree) +;; (let ((al nil)) +;; (radix-tree-iter-mappings tree (lambda (p v) (push (cons p v) al))) +;; al)) + +(defun radix-tree-count (tree) + (let ((i 0)) + (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/re-builder.el b/lisp/emacs-lisp/re-builder.el index a499b038b93..01e5241f6e3 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -1,6 +1,6 @@ ;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*- -;; Copyright (C) 1999-2015 Free Software Foundation, Inc. +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index e315733e222..40033180770 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,6 +1,6 @@ -;;; regexp-opt.el --- generate efficient regexps to match strings +;;; regexp-opt.el --- generate efficient regexps to match strings -*- lexical-binding: t -*- -;; Copyright (C) 1994-2015 Free Software Foundation, Inc. +;; Copyright (C) 1994-2016 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon@gnu.org> ;; Maintainer: emacs-devel@gnu.org @@ -86,18 +86,44 @@ ;;;###autoload (defun regexp-opt (strings &optional paren) "Return a regexp to match a string in the list STRINGS. -Each string should be unique in STRINGS and should not contain any regexps, -quoted or not. If optional PAREN is non-nil, ensure that the returned regexp -is enclosed by at least one regexp grouping construct. -The returned regexp is typically more efficient than the equivalent regexp: +Each string should be unique in STRINGS and should not contain +any regexps, quoted or not. Optional PAREN specifies how the +returned regexp is surrounded by grouping constructs. - (let ((open (if PAREN \"\\\\(\" \"\")) (close (if PAREN \"\\\\)\" \"\"))) - (concat open (mapconcat \\='regexp-quote STRINGS \"\\\\|\") close)) +The optional argument PAREN can be any of the following: -If PAREN is `words', then the resulting regexp is additionally surrounded -by \\=\\< and \\>. -If PAREN is `symbols', then the resulting regexp is additionally surrounded -by \\=\\_< and \\_>." +a string + the resulting regexp is preceded by PAREN and followed by + \\), e.g. use \"\\\\(?1:\" to produce an explicitly numbered + group. + +`words' + the resulting regexp is surrounded by \\=\\<\\( and \\)\\>. + +`symbols' + the resulting regexp is surrounded by \\_<\\( and \\)\\_>. + +non-nil + the resulting regexp is surrounded by \\( and \\). + +nil + the resulting regexp is surrounded by \\(?: and \\), if it is + necessary to ensure that a postfix operator appended to it will + apply to the whole expression. + +The resulting regexp is equivalent to but usually more efficient +than that of a simplified version: + + (defun simplified-regexp-opt (strings &optional paren) + (let ((parens + (cond ((stringp paren) (cons paren \"\\\\)\")) + ((eq paren 'words) '(\"\\\\\\=<\\\\(\" . \"\\\\)\\\\>\")) + ((eq paren 'symbols) '(\"\\\\_<\\\\(\" . \"\\\\)\\\\_>\")) + ((null paren) '(\"\\\\(?:\" . \"\\\\)\")) + (t '(\"\\\\(\" . \"\\\\)\"))))) + (concat (car paren) + (mapconcat 'regexp-quote strings \"\\\\|\") + (cdr paren))))" (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) @@ -236,7 +262,7 @@ CHARS should be a list of characters." ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; - (let* ((charmap (make-char-table 'case-table)) + (let* ((charmap (make-char-table 'regexp-opt-charset)) (start -1) (end -2) (charset "") (bracket "") (dash "") (caret "")) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 2b317f6e253..bbcf501d1e9 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,6 +1,6 @@ ;;; regi.el --- REGular expression Interpreting engine -;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2016 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Maintainer: bwarsaw@cen.com diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 2447dfa8e38..c6684ec9493 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,6 +1,6 @@ -;;; ring.el --- handle rings of items +;;; ring.el --- handle rings of items -*- lexical-binding: t; -*- -;; Copyright (C) 1992, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions @@ -160,14 +160,15 @@ will be performed." (size (ring-size ring)) (vect (cddr ring)) lst) - (dotimes (var (cadr ring) lst) - (push (aref vect (mod (+ start var) size)) lst)))) + (dotimes (var (cadr ring)) + (push (aref vect (mod (+ start var) size)) lst)) + lst)) (defun ring-member (ring item) "Return index of ITEM if on RING, else nil. Comparison is done via `equal'. The index is 0-based." (catch 'found - (dotimes (ind (ring-length ring) nil) + (dotimes (ind (ring-length ring)) (when (equal item (ring-ref ring ind)) (throw 'found ind))))) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index a5ff9722698..66d295e221f 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,6 +1,6 @@ ;;; rx.el --- sexp notation for regular expressions -;; Copyright (C) 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 68265094c17..2b4330c1a3c 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -1,10 +1,10 @@ ;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*- -;; Copyright (C) 2014-2015 Free Software Foundation, Inc. +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 2.2 +;; Version: 2.19 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -46,7 +46,7 @@ ;; - `seq-elt' ;; - `seq-length' ;; - `seq-do' -;; - `seq-p' +;; - `seqp' ;; - `seq-subseq' ;; - `seq-into-sequence' ;; - `seq-copy' @@ -57,7 +57,7 @@ ;;; Code: (eval-when-compile (require 'cl-generic)) -(require 'cl-extra) ;; for cl-subseq +(require 'cl-lib) ;; for cl-subseq (defmacro seq-doseq (spec &rest body) "Loop over a sequence. @@ -79,7 +79,7 @@ corresponding element of SEQUENCE. Extra elements of the sequence are ignored if fewer PATTERNS are given, and the match does not fail." - `(and (pred seq-p) + `(and (pred seqp) ,@(seq--make-pcase-bindings patterns))) (defmacro seq-let (args sequence &rest body) @@ -87,7 +87,7 @@ given, and the match does not fail." ARGS can also include the `&rest' marker followed by a variable name to be bound to the rest of SEQUENCE." - (declare (indent 2) (debug t)) + (declare (indent 2) (debug (sexp form body))) `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) ,@body)) @@ -117,7 +117,17 @@ Return SEQUENCE." (defalias 'seq-each #'seq-do) -(cl-defgeneric seq-p (sequence) +(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)) @@ -127,7 +137,7 @@ Return SEQUENCE." (cl-defgeneric seq-subseq (sequence start &optional end) "Return the sequence of elements of SEQUENCE from START to END. -END is inclusive. +END is exclusive. If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end. Signal an @@ -144,6 +154,18 @@ if positive or too small if negative)." sequence) (nreverse result))) +(defun seq-map-indexed (function sequence) + "Return the result of applying FUNCTION to each element of SEQUENCE. +Unlike `seq-map', FUNCTION takes two arguments: the element of +the sequence, and its index within the sequence." + (let ((index 0)) + (seq-map (lambda (elt) + (prog1 + (funcall function elt index) + (setq index (1+ index)))) + sequence))) + + ;; faster implementation for sequences (sequencep) (cl-defmethod seq-map (function (sequence sequence)) (mapcar function sequence)) @@ -206,6 +228,16 @@ The result is a sequence of the same type as SEQUENCE." (cl-defmethod seq-sort (pred (list list)) (sort (seq-copy list) pred)) +(defun seq-sort-by (function pred sequence) + "Sort SEQUENCE using PRED as a comparison function. +Elements of SEQUENCE are transformed by FUNCTION before being +sorted. FUNCTION must be a function of one argument." + (seq-sort (lambda (a b) + (funcall pred + (funcall function a) + (funcall function b))) + sequence)) + (cl-defgeneric seq-reverse (sequence) "Return a sequence with elements of SEQUENCE in reverse order." (let ((result '())) @@ -317,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) @@ -433,7 +466,7 @@ SEQUENCE must be a sequence of numbers or markers." "Return a list of `(seq ...)' pcase patterns from the argument list ARGS." (cons 'seq (seq-map (lambda (elt) - (if (seq-p elt) + (if (seqp elt) (seq--make-pcase-patterns elt) elt)) args))) @@ -443,16 +476,20 @@ SEQUENCE must be a sequence of numbers or markers." "Return element of SEQUENCE at the index N. If no element is found, return nil." (ignore-errors (seq-elt sequence n))) + +(cl-defgeneric seq-random-elt (sequence) + "Return a random element from SEQUENCE. +Signal an error if SEQUENCE is empty." + (if (seq-empty-p sequence) + (error "Sequence cannot be empty") + (seq-elt sequence (random (seq-length sequence))))) ;;; Optimized implementations for lists (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/shadow.el b/lisp/emacs-lisp/shadow.el index 229bb587488..5dddd23531f 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,6 +1,6 @@ ;;; shadow.el --- locate Emacs Lisp file shadowings -;; Copyright (C) 1995, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001-2016 Free Software Foundation, Inc. ;; Author: Terry Jones <terry@santafe.edu> ;; Keywords: lisp diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 738bdddcddf..1d8f0cb8f5d 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ ;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- -;; Copyright (C) 2010-2015 Free Software Foundation, Inc. +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation @@ -717,9 +717,10 @@ Possible return values: (goto-char pos) (throw 'return (list t epos - (buffer-substring-no-properties - epos - (+ epos (if (< (point) epos) -1 1)))))))) + (unless (= (point) epos) + (buffer-substring-no-properties + epos + (+ epos (if (< (point) epos) -1 1))))))))) (if (eq pos (point)) ;; We did not move, so let's abort the loop. (throw 'return (list t (point)))))) @@ -809,7 +810,12 @@ Possible return values: nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp (indirect-function smie-backward-token-function) - (indirect-function #'backward-sexp) + (lambda (n) + (if (bobp) + ;; Arguably backward-sexp should signal this error for us. + (signal 'scan-error + (list "Beginning of buffer" (point) (point))) + (backward-sexp n))) (indirect-function #'smie-op-left) (indirect-function #'smie-op-right) halfsexp)) @@ -1487,7 +1493,10 @@ should not be computed on the basis of the following token." (let ((endpos (point))) (goto-char pos) (forward-line 1) - (and (equal res (smie-indent-forward-token)) + ;; As seen in bug#22960, pos may be inside + ;; a string, and forward-token may then stumble. + (and (ignore-errors + (equal res (smie-indent-forward-token))) (eq (point) endpos))))) nil (goto-char pos) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index e6d451ac62e..7d1e1c9237a 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -1,6 +1,6 @@ ;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*- -;; Copyright (C) 2013-2015 Free Software Foundation, Inc. +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: convenience @@ -33,6 +33,7 @@ ;;; Code: (require 'pcase) +(eval-when-compile (require 'cl-lib)) (defmacro internal--thread-argument (first? &rest forms) @@ -146,15 +147,11 @@ to bind a single value, BINDINGS can just be a plain tuple." (defsubst hash-table-keys (hash-table) "Return a list of keys in HASH-TABLE." - (let ((keys '())) - (maphash (lambda (k _v) (push k keys)) hash-table) - keys)) + (cl-loop for k being the hash-keys of hash-table collect k)) (defsubst hash-table-values (hash-table) "Return a list of values in HASH-TABLE." - (let ((values '())) - (maphash (lambda (_k v) (push v values)) hash-table) - values)) + (cl-loop for v being the hash-values of hash-table collect v)) (defsubst string-empty-p (string) "Check whether STRING is empty." @@ -198,6 +195,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 d446a2c0af7..ac509b3465d 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,6 +1,6 @@ ;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- -;; Copyright (C) 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 2000-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal @@ -272,9 +272,10 @@ Note: back-references in REGEXPs do not work." (cond ,@(nreverse branches)))))) (defun syntax-propertize-via-font-lock (keywords) - "Propertize for syntax in START..END using font-lock syntax. + "Propertize for syntax using font-lock syntax. KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. -The return value is a function suitable for `syntax-propertize-function'." +The return value is a function (with two parameters, START and +END) suitable for `syntax-propertize-function'." (lambda (start end) (with-no-warnings (let ((font-lock-syntactic-keywords keywords)) @@ -283,7 +284,7 @@ The return value is a function suitable for `syntax-propertize-function'." (setq keywords font-lock-syntactic-keywords))))) (defun syntax-propertize (pos) - "Ensure that syntax-table properties are set until POS." + "Ensure that syntax-table properties are set until POS (a buffer point)." (when (< syntax-propertize--done pos) (if (null syntax-propertize-function) (setq syntax-propertize--done (max (point-max) pos)) @@ -315,6 +316,9 @@ The return value is a function 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) @@ -416,6 +420,9 @@ point (where the PPSS is equivalent to nil).") (error nil))) syntax-ppss-stats)) +(defvar-local syntax-ppss-table nil + "Syntax-table to use during `syntax-ppss', if any.") + (defun syntax-ppss (&optional pos) "Parse-Partial-Sexp State at POS, defaulting to point. The returned value is the same as that of `parse-partial-sexp' @@ -431,6 +438,7 @@ running the hook." (unless pos (setq pos (point))) (syntax-propertize pos) ;; + (with-syntax-table (or syntax-ppss-table (syntax-table)) (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last)) (ppss nil) @@ -567,7 +575,7 @@ running the hook." ;; we may end up calling parse-partial-sexp with a position before ;; point-min. In that case, just parse from point-min assuming ;; a nil state. - (parse-partial-sexp (point-min) pos))))) + (parse-partial-sexp (point-min) pos)))))) ;; Debugging functions diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 4bd8a19937d..9523d5e89e3 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -1,6 +1,6 @@ ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- -;; Copyright (C) 2011-2015 Free Software Foundation, Inc. +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ;; Author: Chong Yidong <cyd@stupidchicken.com> ;; Keywords: extensions, lisp @@ -102,6 +102,8 @@ It is called with two arguments, ID and COLS. ID is a Lisp object identifying the entry, and COLS is a vector of column descriptors, as documented in `tabulated-list-entries'.") +(defvar tabulated-list--near-rows) + (defvar-local tabulated-list-sort-key nil "Sort key for the current Tabulated List mode buffer. If nil, no additional sorting is performed. @@ -257,6 +259,12 @@ Do nothing if `tabulated-list--header-string' is nil." (make-overlay (point-min) (point)))) (overlay-put tabulated-list--header-overlay 'face 'underline)))) +(defsubst tabulated-list-header-overlay-p (&optional pos) + "Return non-nil if there is a fake header. +Optional arg POS is a buffer position where to look for a fake header; +defaults to `point-min'." + (overlays-at (or pos (point-min)))) + (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." @@ -298,6 +306,14 @@ column. Negate the predicate that would be returned if (lambda (a b) (not (funcall sorter a b))) sorter)))) +(defsubst tabulated-list--col-local-max-widths (col) + "Return maximum entry widths at column COL around current row. +Check the current row, the previous one and the next row." + (apply #'max (mapcar (lambda (x) + (let ((nt (elt x col))) + (string-width (if (stringp nt) nt (car nt))))) + tabulated-list--near-rows))) + (defun tabulated-list-print (&optional remember-pos update) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is @@ -340,8 +356,14 @@ changing `tabulated-list-sort-key'." (unless tabulated-list-use-header-line (tabulated-list-print-fake-header))) ;; Finally, print the resulting list. - (dolist (elt entries) - (let ((id (car elt))) + (while entries + (let* ((elt (car entries)) + (tabulated-list--near-rows + (list + (or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt)) + (cadr elt) + (or (cadr (cadr entries)) (cadr elt)))) + (id (car elt))) (and entry-id (equal entry-id id) (setq entry-id nil @@ -368,7 +390,8 @@ changing `tabulated-list-sort-key'." (t t))) (let ((old (point))) (forward-line 1) - (delete-region old (point))))))) + (delete-region old (point)))))) + (setq entries (cdr entries))) (set-buffer-modified-p nil) ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt @@ -402,8 +425,6 @@ of column descriptors." N is the column number, COL-DESC is a column descriptor (see `tabulated-list-entries'), and X is the column number at point. Return the column number after insertion." - ;; TODO: don't truncate to `width' if the next column is align-right - ;; and has some space left. (let* ((format (aref tabulated-list-format n)) (name (nth 0 format)) (width (nth 1 format)) @@ -414,12 +435,29 @@ Return the column number after insertion." (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) - (not-last-col (< (1+ n) (length tabulated-list-format)))) + (not-last-col (< (1+ n) (length tabulated-list-format))) + available-space) + (when not-last-col + (let* ((next-col-format (aref tabulated-list-format (1+ n))) + (next-col-right-align (plist-get (nthcdr 3 next-col-format) + :right-align)) + (next-col-width (nth 1 next-col-format))) + (setq available-space + (if (and (not right-align) + next-col-right-align) + (- + (+ width next-col-width) + (min next-col-width + (tabulated-list--col-local-max-widths (1+ n)))) + width)))) ;; Truncate labels if necessary (except last column). - (and not-last-col - (> label-width width) - (setq label (truncate-string-to-width label width nil nil t) - label-width width)) + ;; Don't truncate to `width' if the next column is align-right + ;; and has some space left, truncate to `available-space' instead. + (when (and not-last-col + (> label-width available-space) + (setq label (truncate-string-to-width + label available-space nil nil t) + label-width available-space))) (setq label (bidi-string-mark-left-to-right label)) (when (and right-align (> width label-width)) (let ((shift (- width label-width))) @@ -437,7 +475,7 @@ Return the column number after insertion." (when not-last-col (when (> pad-right 0) (insert (make-string pad-right ?\s))) (insert (propertize - (make-string (- next-x x label-width pad-right) ?\s) + (make-string (- width (min width label-width)) ?\s) 'display `(space :align-to ,next-x)))) (put-text-property opoint (point) 'tabulated-list-column-name name) next-x))) @@ -494,7 +532,12 @@ this is the vector stored within it." (when (< pos eol) (delete-region pos (next-single-property-change pos prop nil eol)) (goto-char pos) - (tabulated-list-print-col col desc (current-column)) + (let ((tabulated-list--near-rows + (list + (tabulated-list-get-entry (point-at-bol 0)) + entry + (or (tabulated-list-get-entry (point-at-bol 2)) entry)))) + (tabulated-list-print-col col desc (current-column))) (if change-entry-data (aset entry col desc)) (put-text-property pos (point) 'tabulated-list-id id) @@ -571,7 +614,6 @@ data in an ewoc may instead specify a printer function (e.g., one that calls `ewoc-enter-last'), with `tabulated-list-print-entry' as the ewoc pretty-printer." (setq-local truncate-lines t) - (setq-local buffer-read-only t) (setq-local buffer-undo-list t) (setq-local revert-buffer-function #'tabulated-list-revert) (setq-local glyphless-char-display tabulated-list-glyphless-char-display) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 61a21dc74fd..b7a3d1ae2b8 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,6 +1,6 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index c683826535b..cb18f00a8cf 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -1,6 +1,6 @@ ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 110c63f777a..c6a5e3b9d4f 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,6 +1,6 @@ ;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*- -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -184,6 +184,7 @@ call to one of the `testcover-1value-functions'." ;;; Add instrumentation to your module ;;;========================================================================= +;;;###autoload (defun testcover-start (filename &optional byte-compile) "Uses edebug to instrument all macros and functions in FILENAME, then changes the instrumentation from edebug to testcover--much faster, no diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index 0c5816a616d..4d7b0732412 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -1,6 +1,6 @@ ;;; thunk.el --- Lazy form evaluation -*- lexical-binding: t -*- -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el new file mode 100644 index 00000000000..9b13e52dd7c --- /dev/null +++ b/lisp/emacs-lisp/timer-list.el @@ -0,0 +1,112 @@ +;;; timer-list.el --- list active timers in a buffer + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +;;;###autoload +(defun timer-list (&optional _ignore-auto _nonconfirm) + "List all timers in a buffer." + (interactive) + (pop-to-buffer-same-window (get-buffer-create "*timer-list*")) + (let ((inhibit-read-only t)) + (erase-buffer) + (timer-list-mode) + (dolist (timer (append timer-list timer-idle-list)) + (insert (format "%4s %10s %8s %s" + ;; Idle. + (if (aref timer 7) + "*" + " ") + ;; Next time. + (let ((time (float-time (list (aref timer 1) + (aref timer 2) + (aref timer 3))))) + (format "%.2f" + (if (aref timer 7) + time + (- (float-time (list (aref timer 1) + (aref timer 2) + (aref timer 3))) + (float-time))))) + ;; Repeat. + (let ((repeat (aref timer 4))) + (cond + ((numberp repeat) + (format "%.2f" (/ repeat 60))) + ((null repeat) + "-") + (t + (format "%s" repeat)))) + ;; Function. + (let ((function (aref timer 5))) + (replace-regexp-in-string + "\n" " " + (cond + ((byte-code-function-p function) + (replace-regexp-in-string + "[^-A-Za-z0-9 ]" "" + (format "%s" function))) + (t + (format "%s" function))))))) + (put-text-property (line-beginning-position) + (1+ (line-beginning-position)) + 'timer timer) + (insert "\n"))) + (goto-char (point-min))) +;; This command can be destructive if they don't know what they are +;; doing. Kids, don't try this at home! +;;;###autoload (put 'timer-list 'disabled "Beware: manually canceling timers can ruin your Emacs session.") + +(defvar timer-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "c" 'timer-list-cancel) + (easy-menu-define nil map "" + '("Timers" + ["Cancel" timer-list-cancel t])) + map)) + +(define-derived-mode timer-list-mode special-mode "timer-list" + "Mode for listing and controlling timers." + (setq truncate-lines t) + (buffer-disable-undo) + (setq-local revert-buffer-function 'timer-list) + (setq buffer-read-only t) + (setq header-line-format + (format "%4s %10s %8s %s" + "Idle" "Next" "Repeat" "Function"))) + +(defun timer-list-cancel () + "Cancel the timer on the line under point." + (interactive) + (let ((timer (get-text-property (line-beginning-position) 'timer)) + (inhibit-read-only t)) + (unless timer + (error "No timer on the current line")) + (cancel-timer timer) + (delete-region (line-beginning-position) + (line-beginning-position 2)))) + +(provide 'timer-list) + +;;; timer-list.el ends here diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index c9e3fbe4f7d..64aebeaa818 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,6 +1,6 @@ -;;; timer.el --- run a function with args at some time in future +;;; timer.el --- run a function with args at some time in future -*- lexical-binding: t -*- -;; Copyright (C) 1996, 2001-2015 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Package: emacs @@ -424,6 +424,8 @@ This function returns a timer object which you can use in `cancel-timer'." (defun add-timeout (secs function object &optional repeat) "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. If REPEAT is non-nil, repeat the timer every REPEAT seconds. + +This function returns a timer object which you can use in `cancel-timer'. This function is for compatibility; see also `run-with-timer'." (run-with-timer secs repeat function object)) diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index b652cbe193e..c01262d48a9 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,6 +1,6 @@ ;;; tq.el --- utility to maintain a transaction queue -*- lexical-binding:t -*- -;; Copyright (C) 1985-1987, 1992, 2001-2015 Free Software Foundation, +;; Copyright (C) 1985-1987, 1992, 2001-2016 Free Software Foundation, ;; Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 7a2fb22f3d5..1913a789db6 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,6 +1,6 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- -;; Copyright (C) 1993, 1998, 2000-2015 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1998, 2000-2016 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 35a36b8498c..584684fefc9 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,6 +1,6 @@ ;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index b88af1dbe1a..9ecfcd84bf6 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -1,6 +1,6 @@ ;;; warnings.el --- log and display warnings -;; Copyright (C) 2002-2015 Free Software Foundation, Inc. +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal |