diff options
Diffstat (limited to 'lisp/emacs-lisp')
76 files changed, 7122 insertions, 1930 deletions
diff --git a/lisp/emacs-lisp/.gitignore b/lisp/emacs-lisp/.gitignore index 88830a1c6e8..133e79e817a 100644 --- a/lisp/emacs-lisp/.gitignore +++ b/lisp/emacs-lisp/.gitignore @@ -1,3 +1,2 @@ !*-loaddefs.el -# arch-tag: d0a60bce-b886-4817-b4c3-9a81ba0308bc diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index b37e1c289c1..915a726ae11 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,12 +1,12 @@ ;;; advice.el --- an overloading mechanism for Emacs Lisp functions -;; Copyright (C) 1993, 1994, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2000-2011 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF ;; Created: 12 Dec 1992 ;; Keywords: extensions, lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. @@ -3007,9 +3007,7 @@ in any of these classes." (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) (unless (eq style 'plain) - (push (propertize (concat "This " origtype " is advised.") - 'face 'font-lock-warning-face) - paragraphs)) + (push (concat "This " origtype " is advised.") paragraphs)) (ad-dolist (class ad-advice-classes) (ad-dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring @@ -3965,5 +3963,4 @@ Use only in REAL emergencies." (provide 'advice) -;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0 ;;; advice.el ends here diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index e90c9df7f82..aa85916cc3f 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -1,7 +1,6 @@ ;;; assoc.el --- insert/delete/sort functions on association lists -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc. ;; Author: Barry A. Warsaw <bwarsaw@cen.com> ;; Keywords: extensions @@ -138,5 +137,4 @@ extra values are ignored. Returns the created alist." (provide 'assoc) -;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc ;;; assoc.el ends here diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 433d36c3ef7..163af883334 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -1,11 +1,11 @@ ;;; authors.el --- utility for maintaining Emacs' AUTHORS file -*-coding: utf-8;-*- -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2000-2011 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: Kim F. Storm <storm@cua.dk> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -220,6 +220,9 @@ If REALNAME is nil, ignore that author.") '("vc-\\*\\.el$" "spec.txt$" ".*loaddefs.el$" ; not obsolete, but auto-generated + "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting + "\\.arch-inventory$" + "preferences\\.\\(nib\\|gorm\\)" "vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$") "List of regexps matching obsolete files. Changes to files matching one of the regexps in this list are not @@ -244,6 +247,14 @@ listed.") "Imakefile" "icons/sink.ico" "aixcc.lex" "nxml/char-name/unicode" "js2-mode.el" ; only installed very briefly, replaced by js.el + "cedet/tests/testtemplates.cpp" + "cedet/tests/testusing.cpp" + "cedet/tests/scopetest.cpp" + "cedet/tests/scopetest.java" + "cedet/tests/test.cpp" + "cedet/tests/test.py" + "cedet/tests/teststruct.cpp" + "*.el" ;; Autogen: "cus-load.el" "finder-inf.el" "ldefs-boot.el" ;; Never had any meaningful changes logged, now deleted: @@ -255,7 +266,8 @@ listed.") "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" "CODINGS" "CHARSETS" "calc/INSTALL" "calc/Makefile" - "vms-pp.trans" "_emacs" "batcomp.com" + "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ + "emacsver.texi.in" ;; MH-E stuff not in Emacs: "import-emacs" "release-utils" ;; Erc stuff not in Emacs: @@ -286,6 +298,42 @@ listed.") "List of files and directories to ignore. Changes to files in this list are not listed.") +;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d +;; FIXME It would be better to discover these dynamically. +;; Note that traditionally "Makefile.in" etc have not been in this list. +;; Ditto for "abbrev.texi" etc. +(defconst authors-ambiguous-files + '("chart.el" + "compile.el" + "complete.el" + "cpp.el" + "ctxt.el" + "debug.el" + "dired.el" + "el.el" + "files.el" + "find.el" + "format.el" + "grep.el" + "imenu.el" + "java.el" + "linux.el" + "locate.el" + "make.el" + "mode.el" + "python.el" + "semantic.el" + "shell.el" + "simple.el" + "sort.el" + "speedbar.el" + "srecode.el" + "table.el" + "texi.el" + "util.el" + "wisent.el") + "List of basenames occurring more than once in the source.") + ;; FIXME :cowrote entries here can be overwritten by :wrote entries ;; derived from a file's Author: header (eg mh-e). This really means ;; the Author: header is erroneous. @@ -307,7 +355,7 @@ Changes to files in this list are not listed.") ;; No longer distributed. ;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") ("Paul Eggert" :wrote "rcs2log" "vcdiff") - ("Fred Fish" :changed "unexec.c") + ("Fred Fish" :changed "unexcoff.c") ;; No longer distributed. ;;; ("Tim Fleehart" :wrote "makefile.nt") ("Keith Gabryelski" :wrote "hexl.c") @@ -330,13 +378,13 @@ Changes to files in this list are not listed.") "indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h") ;; ibmrt.h, ibmrt-aix.h no longer distributed. ("International Business Machines" :changed "emacs.c" "fileio.c" - "process.c" "sysdep.c" "unexec.c") + "process.c" "sysdep.c" "unexcoff.c") ;; No longer distributed. ;;; ("Ishikawa Chiaki" :changed "aviion.h" "dgux.h") ;; ymakefile no longer distributed. ("Michael K. Johnson" :changed "configure.in" "emacs.c" "intel386.h" "mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h" - "systty.h" "unexec.c" "linux.h") + "systty.h" "unexcoff.c" "linux.h") ;; No longer distributed. ;;; ("Kyle Jones" :wrote "mldrag.el") ("Henry Kautz" :wrote "bib-mode.el") @@ -361,7 +409,7 @@ Changes to files in this list are not listed.") "rmail.el" "rmailedit.el" "rmailkwd.el" "rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el" ;; It was :wrote for xmenu.c, but it has been rewritten since. - "server.el" "lisp.h" "sysdep.c" "unexec.c" "xmenu.c") + "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c") ("Niall Mansfield" :changed "etags.c") ("Brian Marick" :cowrote "hideif.el") ("Marko Kohtala" :changed "info.el") @@ -416,9 +464,9 @@ Changes to files in this list are not listed.") ("Kayvan Sylvan" :changed "supercite.el") ;; No longer distributed: emacsserver.c, tcp.c. ("Spencer Thomas" :changed "emacsclient.c" "server.el" - "dabbrev.el" "unexec.c" "gnus.texi") + "dabbrev.el" "unexcoff.c" "gnus.texi") ("Jonathan Vail" :changed "vc.el") - ("James Van Artsdalen" :changed "usg5-4.h" "unexec.c") + ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c") ;; No longer distributed: src/makefile.nt, lisp/makefile.nt ;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch]; ;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c; @@ -427,6 +475,7 @@ Changes to files in this list are not listed.") ("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c" "w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h") ("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h") + ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]") ;; Not using this version any more. ;;; ("Pace Willisson" :wrote "ispell.el") ;; FIXME overwritten by Author:. @@ -457,17 +506,23 @@ Changes to files in this list are not listed.") "getdate.y" "ymakefile" "permute-index" "index.perm" + "ibmrs6000.inp" + "b2m.c" "b2m.1" "b2m.pl" + "emacs.bash" "emacs.csh" "ms-kermit" "emacs.ico" "emacs21.ico" - "LPF" "LEDIT" "OTHER.EMACSES" + "BABYL" "LPF" "LEDIT" "OTHER.EMACSES" "emacs16_mac.png" "emacs24_mac.png" "emacs256_mac.png" "emacs32_mac.png" "emacs48_mac.png" "emacs512_mac.png" + "revdiff" ; admin/ + "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ + "mac-fix-env.m" ;; Deleted vms stuff: "temacs.opt" "descrip.mms" "compile.com" "link.com" ) - "File names which are valid, but no longer exist (or cannot be -found) in the repository.") + "File names which are valid, but no longer exist (or cannot be found) +in the repository.") (defconst authors-renamed-files-alist '(("nt.c" . "w32.c") ("nt.h" . "w32.h") @@ -504,6 +559,7 @@ found) in the repository.") ;; index and pick merged into search. ("mh-index.el" . "mh-search.el") ("mh-pick.el" . "mh-search.el") + ("font-setting.el" . "dynamic-setting.el") ;; INSTALL-CVS -> .CVS -> .BZR ("INSTALL-CVS" . "INSTALL.BZR") ("INSTALL.CVS" . "INSTALL.BZR") @@ -529,12 +585,16 @@ found) in the repository.") ("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc") ("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" ) ("texi/url.txi" . "url.texi") + ("edt-user.doc" . "edt.texi") + ("DEV-NOTES" . "nextstep") ;; Moved to different directories. ("ctags.1" . "ctags.1") ("etags.1" . "etags.1") ("emacs.1" . "emacs.1") ("emacsclient.1" . "emacsclient.1") ("icons/emacs21.ico" . "emacs21.ico") + ;; Moved from admin/nt/ to nt/. + ("nt/README.W32" . "README.W32") ) "Alist of files which have been renamed during their lifetime. Elements are (OLDNAME . NEWNAME).") @@ -573,10 +633,25 @@ Otherwise, the file name is accepted as is.") (defvar authors-checked-files-alist) (defvar authors-invalid-file-names) +(defun authors-disambiguate-file-name (fullname) + "Convert FULLNAME to an unambiguous relative-name." + (let ((relname (file-name-nondirectory fullname)) + parent) + (if (member relname authors-ambiguous-files) + ;; In case of ambiguity, just prepend the parent directory. + ;; FIXME obviously this is not a perfect solution. + (if (string-equal "lisp" + (setq parent (file-name-nondirectory + (directory-file-name + (file-name-directory fullname))))) + relname + (format "%s/%s" parent relname)) + relname))) + (defun authors-canonical-file-name (file log-file pos author) "Return canonical file name for FILE found in LOG-FILE. Checks whether FILE is a valid (existing) file name, has been renamed, -or is on the list of removed files. Returns the non-diretory part of +or is on the list of removed files. Returns the non-directory part of the file name. Only uses the LOG-FILE position POS and associated AUTHOR to print a message if FILE is not found." ;; FILE should be re-checked in every different directory associated @@ -593,7 +668,7 @@ to print a message if FILE is not found." (file-exists-p file) (file-exists-p relname) (file-exists-p (concat "etc/" relname))) - (setq valid relname) + (setq valid (authors-disambiguate-file-name fullname)) (setq valid (assoc file authors-renamed-files-alist)) (if valid (setq valid (cdr valid)) @@ -610,6 +685,7 @@ to print a message if FILE is not found." (cons (cons fullname valid) authors-checked-files-alist)) (unless (or valid (member file authors-ignored-files) + (authors-obsolete-file-p file) (string-match "[*]" file) (string-match "^[0-9.]+$" file)) (setq authors-invalid-file-names @@ -758,7 +834,7 @@ TABLE is a hash table to add author information to." (enable-local-variables :safe) ; for find-file, hence let* (enable-local-eval nil) (buffer (find-file-noselect file))) - (setq file (file-name-nondirectory file)) + (setq file (authors-disambiguate-file-name (expand-file-name file))) (with-current-buffer buffer (save-restriction (widen) @@ -956,5 +1032,4 @@ the Emacs source tree, from which to build the file." (provide 'authors) -;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1 ;;; authors.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 1f7837ba43a..7b610d11b0f 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,11 +1,10 @@ ;; autoload.el --- maintain autoloads in loaddefs.el -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 1991-1997, 2001-2011 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -109,29 +108,48 @@ or macro definition or a defcustom)." (let* ((macrop (memq car '(defmacro defmacro*))) (name (nth 1 form)) (args (case car - ((defun defmacro defun* defmacro* - define-overloadable-function) (nth 2 form)) - ((define-skeleton) '(&optional str arg)) - ((define-generic-mode define-derived-mode - define-compilation-mode) nil) - (t))) + ((defun defmacro defun* defmacro* + define-overloadable-function) (nth 2 form)) + ((define-skeleton) '(&optional str arg)) + ((define-generic-mode define-derived-mode + define-compilation-mode) nil) + (t))) (body (nthcdr (get car 'doc-string-elt) form)) (doc (if (stringp (car body)) (pop body)))) (when (listp args) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (setq doc (help-add-fundoc-usage doc args))) - ;; `define-generic-mode' quotes the name, so take care of that - (list 'autoload (if (listp name) name (list 'quote name)) file doc - (or (and (memq car '(define-skeleton define-derived-mode - define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode - define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) - (if macrop (list 'quote 'macro) nil)))) + (let ((exp + ;; `define-generic-mode' quotes the name, so take care of that + (list 'autoload (if (listp name) name (list 'quote name)) + file doc + (or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode + define-minor-mode)) t) + (eq (car-safe (car body)) 'interactive)) + (if macrop (list 'quote 'macro) nil)))) + (when macrop + ;; Special case to autoload some of the macro's declarations. + (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) + (exps '())) + (when (eq (car decls) 'declare) + ;; FIXME: We'd like to reuse macro-declaration-function, + ;; but we can't since it doesn't return anything. + (dolist (decl decls) + (case (car-safe decl) + (indent + (push `(put ',name 'lisp-indent-function ',(cadr decl)) + exps)) + (doc-string + (push `(put ',name 'doc-string-elt ',(cadr decl)) exps)))) + (when exps + (setq exp `(progn ,exp ,@exps)))))) + exp))) ;; For defclass forms, use `eieio-defclass-autoload'. ((eq car 'defclass) @@ -259,14 +277,17 @@ put the output in." TYPE (default \"autoloads\") is a string stating the type of information contained in FILE. If FEATURE is non-nil, FILE will provide a feature. FEATURE may be a string naming the -feature, otherwise it will be based on FILE's name." +feature, otherwise it will be based on FILE's name. + +At present, a feature is in fact always provided, but this should +not be relied upon." (let ((basename (file-name-nondirectory file))) (concat ";;; " basename " --- automatically extracted " (or type "autoloads") "\n" ";;\n" ";;; Code:\n\n" " \n" - ;; This is used outside of autoload.el. + ;; This is used outside of autoload.el, eg cus-dep, finder. "(provide '" (if (stringp feature) feature @@ -325,7 +346,29 @@ which lists the file name and which functions are in it, etc." "File local variable to prevent scanning this file for autoload cookies.") (defun autoload-file-load-name (file) - (let ((name (file-name-nondirectory file))) + "Compute the name that will be used to load FILE." + ;; OUTFILE should be the name of the global loaddefs.el file, which + ;; is expected to be at the root directory of the files we're + ;; scanning for autoloads and will be in the `load-path'. + (let* ((outfile (default-value 'generated-autoload-file)) + (name (file-relative-name file (file-name-directory outfile))) + (names '()) + (dir (file-name-directory outfile))) + ;; If `name' has directory components, only keep the + ;; last few that are really needed. + (while name + (setq name (directory-file-name name)) + (push (file-name-nondirectory name) names) + (setq name (file-name-directory name))) + (while (not name) + (cond + ((null (cdr names)) (setq name (car names))) + ((file-exists-p (expand-file-name "subdirs.el" dir)) + ;; FIXME: here we only check the existence of subdirs.el, + ;; 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 "/"))))) (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) (substring name 0 (match-beginning 0)) name))) @@ -340,6 +383,8 @@ Return non-nil in the case where no autoloads were added at point." (interactive "fGenerate autoloads for file: ") (autoload-generate-file-autoloads file (current-buffer))) +(defvar print-readably) + ;; When called from `generate-file-autoloads' we should ignore ;; `generated-autoload-file' altogether. When called from ;; `update-file-autoloads' we don't know `outbuf'. And when called from @@ -370,9 +415,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (visited (get-file-buffer file)) (otherbuf nil) (absfile (expand-file-name file)) - relfile ;; nil until we found a cookie. - output-start) + output-start ostart) (with-current-buffer (or visited ;; It is faster to avoid visiting the file. (autoload-find-file file)) @@ -382,7 +426,10 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (setq load-name (if (stringp generated-autoload-load-name) generated-autoload-load-name - (autoload-file-load-name file))) + (autoload-file-load-name absfile))) + (when (and outfile + (not (equal outfile (autoload-generated-file)))) + (setq otherbuf t)) (save-excursion (save-restriction (widen) @@ -393,26 +440,22 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE ((looking-at (regexp-quote generate-autoload-cookie)) ;; If not done yet, figure out where to insert this text. (unless output-start - (when (and outfile - (not (equal outfile (autoload-generated-file)))) - ;; A file-local setting of autoload-generated-file says - ;; we should ignore OUTBUF. - (setq outbuf nil) - (setq otherbuf t)) - (unless outbuf - (setq outbuf (autoload-find-destination absfile)) - (unless outbuf - ;; The file has autoload cookies, but they're - ;; already up-to-date. If OUTFILE is nil, the - ;; entries are in the expected OUTBUF, otherwise - ;; they're elsewhere. - (throw 'done outfile))) - (with-current-buffer outbuf - (setq relfile (file-relative-name absfile)) - (setq output-start (point))) - ;; (message "file=%S, relfile=%S, dest=%S" - ;; file relfile (autoload-generated-file)) - ) + (let ((outbuf + (or (if otherbuf + ;; A file-local setting of + ;; autoload-generated-file says we + ;; should ignore OUTBUF. + nil + outbuf) + (autoload-find-destination absfile load-name) + ;; The file has autoload cookies, but they're + ;; already up-to-date. If OUTFILE is nil, the + ;; entries are in the expected OUTBUF, + ;; otherwise they're elsewhere. + (throw 'done otherbuf)))) + (with-current-buffer outbuf + (setq output-start (point-marker) + ostart (point))))) (search-forward generate-autoload-cookie) (skip-chars-forward " \t") (if (eolp) @@ -424,7 +467,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (if autoload (push (nth 1 form) autoloads-done) (setq autoload form)) - (let ((autoload-print-form-outbuf outbuf)) + (let ((autoload-print-form-outbuf + (marker-buffer output-start))) (autoload-print-form autoload))) (error (message "Error in %s: %S" file err))) @@ -439,7 +483,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (forward-char 1)) (point)) (progn (forward-line 1) (point))) - outbuf))) + (marker-buffer output-start)))) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) @@ -451,40 +495,44 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (let ((secondary-autoloads-file-buf (if (local-variable-p 'generated-autoload-file) (current-buffer)))) - (with-current-buffer outbuf + (with-current-buffer (marker-buffer output-start) (save-excursion ;; Insert the section-header line which lists the file name ;; and which functions are in it, etc. + (assert (= ostart output-start)) (goto-char output-start) - (autoload-insert-section-header - outbuf autoloads-done load-name relfile - (if secondary-autoloads-file-buf - ;; MD5 checksums are much better because they do not - ;; change unless the file changes (so they'll be - ;; equal on two different systems and will change - ;; less often than time-stamps, thus leading to fewer - ;; unneeded changes causing spurious conflicts), but - ;; using time-stamps is a very useful optimization, - ;; so we use time-stamps for the main autoloads file - ;; (loaddefs.el) where we have special ways to - ;; circumvent the "random change problem", and MD5 - ;; checksum in secondary autoload files where we do - ;; not need the time-stamp optimization because it is - ;; already provided by the primary autoloads file. - (md5 secondary-autoloads-file-buf - ;; We'd really want to just use - ;; `emacs-internal' instead. - nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) - (insert ";;; Generated autoloads from " relfile "\n")) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer output-start) + autoloads-done load-name relfile + (if secondary-autoloads-file-buf + ;; MD5 checksums are much better because they do not + ;; change unless the file changes (so they'll be + ;; equal on two different systems and will change + ;; less often than time-stamps, thus leading to fewer + ;; unneeded changes causing spurious conflicts), but + ;; using time-stamps is a very useful optimization, + ;; so we use time-stamps for the main autoloads file + ;; (loaddefs.el) where we have special ways to + ;; circumvent the "random change problem", and MD5 + ;; checksum in secondary autoload files where we do + ;; not need the time-stamp optimization because it is + ;; already provided by the primary autoloads file. + (md5 secondary-autoloads-file-buf + ;; We'd really want to just use + ;; `emacs-internal' instead. + nil nil 'emacs-mule-unix) + (nth 5 (file-attributes relfile)))) + (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) (message "Generating autoloads for %s...done" file)) (or visited ;; We created this buffer, so we should kill it. (kill-buffer (current-buffer)))) - ;; If the entries were added to some other buffer, then the file - ;; doesn't add entries to OUTFILE. - (or (not output-start) otherbuf)))) + (or (not output-start) + ;; If the entries were added to some other buffer, then the file + ;; doesn't add entries to OUTFILE. + otherbuf)))) (defun autoload-save-buffers () (while autoload-modified-buffers @@ -508,15 +556,14 @@ Return FILE if there was no autoload cookie in it, else nil." (message "Autoload section for %s is up to date." file))) (if no-autoloads file))) -(defun autoload-find-destination (file) +(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. Returns a buffer whose point is placed at the requested location. Returns nil if the file's autoloads are uptodate, otherwise removes any prior now out-of-date autoload entries." (catch 'up-to-date - (let* ((load-name (autoload-file-load-name file)) - (buf (current-buffer)) + (let* ((buf (current-buffer)) (existing-buffer (if buffer-file-name buf)) (found nil)) (with-current-buffer @@ -529,7 +576,7 @@ removes any prior now out-of-date autoload entries." (or (eq 0 (coding-system-eol-type buffer-file-coding-system)) (set-buffer-file-coding-system 'unix)) (or (> (buffer-size) 0) - (error "Autoloads file %s does not exist" buffer-file-name)) + (error "Autoloads file %s lacks boilerplate" buffer-file-name)) (or (file-writable-p buffer-file-name) (error "Autoloads file %s is not writable" buffer-file-name)) (widen) @@ -649,6 +696,7 @@ directory or directories specified." (t (autoload-remove-section (match-beginning 0)) (if (autoload-generate-file-autoloads + ;; Passing `current-buffer' makes it insert at point. file (current-buffer) buffer-file-name) (push file no-autoloads)))) (push file done) @@ -657,6 +705,9 @@ directory or directories specified." (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. ((autoload-generate-file-autoloads file nil buffer-file-name) (push file no-autoloads)))) @@ -725,11 +776,13 @@ Calls `update-directory-autoloads' on the command line arguments." (with-temp-buffer (insert-file-contents mfile) (when (re-search-forward "^shortlisp= " nil t) - (setq lim (line-end-position)) - (while (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>" - lim t) + (while (and (not lim) + (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>" + nil t)) (push (expand-file-name (match-string 1) ldir) - autoload-excludes)))))))) + autoload-excludes) + (skip-chars-forward " \t") + (if (eolp) (setq lim t))))))))) (let ((args command-line-args-left)) (setq command-line-args-left nil) (apply 'update-directory-autoloads args))) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 63774bc229f..0a637da0bc1 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 -;; Copyright (C) 1995, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2011 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> @@ -466,5 +466,4 @@ If there is no such element in the tree, the value is nil." (provide 'avl-tree) -;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 ;;; avl-tree.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index ab608cb4c51..34e316b2e48 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,11 +1,11 @@ ;;; backquote.el --- implement the ` Lisp construct -;; Copyright (C) 1990, 1992, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1990, 1992, 1994, 2001-2011 Free Software Foundation, Inc. ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF ;; Keywords: extensions, internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -240,5 +240,4 @@ LEVEL is only used internally and indicates the nesting level: tail)) (t (cons 'list heads))))) -;; arch-tag: 1a26206a-6b5e-4c56-8e24-2eef0f7e0e7a ;;; backquote.el ends here diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 8f6d8a5d9df..86063c512c6 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,7 +1,6 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 2003-2011 Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions @@ -116,5 +115,4 @@ For non-interactive use see also `benchmark-run' and (provide 'benchmark) -;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946 ;;; benchmark.el ends here diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 244b838fa29..fd98b5f41a7 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, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Author: Kim F. Storm <storm@cua.dk> ;; Assignment name: struct.el @@ -649,5 +649,4 @@ The port (if any) is omitted. IP can be a string, as well." (provide 'bindat) -;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 75268100c8d..0f4018dc8da 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,12 +1,12 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -1315,35 +1315,38 @@ "Don't call this!" ;; fetch and return the offset for the current opcode. ;; return nil if this opcode has no offset - ;; OP, PTR and BYTES are used and set dynamically - (defvar op) - (defvar ptr) - (defvar bytes) - (cond ((< op byte-nth) - (let ((tem (logand op 7))) - (setq op (logand op 248)) + ;; Used and set dynamically in byte-decompile-bytecode-1. + (defvar bytedecomp-op) + (defvar bytedecomp-ptr) + (defvar bytedecomp-bytes) + (cond ((< bytedecomp-op byte-nth) + (let ((tem (logand bytedecomp-op 7))) + (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)) + ;; Offset in next byte. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (aref bytedecomp-bytes bytedecomp-ptr)) ((eq tem 7) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytedecomp-bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) (t tem)))) ;offset was in opcode - ((>= op byte-constant) - (prog1 (- op byte-constant) ;offset in opcode - (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - ((and (>= op byte-listN) - (<= op byte-insertN)) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)))) + ((>= bytedecomp-op byte-constant) + (prog1 (- bytedecomp-op byte-constant) ;offset in opcode + (setq bytedecomp-op byte-constant))) + ((and (>= bytedecomp-op byte-constant2) + (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytedecomp-bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) + ((and (>= bytedecomp-op byte-listN) + (<= bytedecomp-op byte-insertN)) + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte + (aref bytedecomp-bytes bytedecomp-ptr)))) ;; This de-compiler is used for inline expansion of compiled functions, @@ -1366,19 +1369,20 @@ ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. ;; In that case, we put a pc value into the list ;; before each insn (or its label). -(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) - (let ((length (length bytes)) - (ptr 0) optr tags op offset +(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec + &optional make-spliceable) + (let ((length (length bytedecomp-bytes)) + (bytedecomp-ptr 0) optr tags bytedecomp-op offset lap tmp endtag) - (while (not (= ptr length)) + (while (not (= bytedecomp-ptr length)) (or make-spliceable - (setq lap (cons ptr lap))) - (setq op (aref bytes ptr) - optr ptr + (setq lap (cons bytedecomp-ptr lap))) + (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) + optr bytedecomp-ptr offset (disassemble-offset)) ; this does dynamic-scope magic - (setq op (aref byte-code-vector op)) - (cond ((memq op byte-goto-ops) + (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) + (cond ((memq bytedecomp-op byte-goto-ops) ;; it's a pc (setq offset (cdr (or (assq offset tags) @@ -1386,27 +1390,28 @@ (cons (cons offset (byte-compile-make-tag)) tags))))))) - ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) - ((memq op byte-constref-ops))) + ((cond ((eq bytedecomp-op 'byte-constant2) + (setq bytedecomp-op 'byte-constant) t) + ((memq bytedecomp-op byte-constref-ops))) (setq tmp (if (>= offset (length constvec)) (list 'out-of-range offset) (aref constvec offset)) - offset (if (eq op 'byte-constant) + offset (if (eq bytedecomp-op 'byte-constant) (byte-compile-get-constant tmp) (or (assq tmp byte-compile-variables) (car (setq byte-compile-variables (cons (list tmp) byte-compile-variables))))))) ((and make-spliceable - (eq op 'byte-return)) - (if (= ptr (1- length)) - (setq op nil) + (eq bytedecomp-op 'byte-return)) + (if (= bytedecomp-ptr (1- length)) + (setq bytedecomp-op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) + bytedecomp-op 'byte-goto)))) ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons op (or offset 0))) + (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) lap)) - (setq ptr (1+ ptr))) + (setq bytedecomp-ptr (1+ bytedecomp-ptr))) ;; take off the dummy nil op that we replaced a trailing "return" with. (let ((rest lap)) (while rest @@ -2035,5 +2040,4 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-optimize-lapcode)))) nil) -;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 ;;; byte-opt.el ends here diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 42cd8d9ca55..524f4f1b465 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,12 +1,12 @@ ;;; byte-run.el --- byte-compiler support for inlining -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -65,7 +65,6 @@ The return value of this function is not used." ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. (fset 'inline 'progn) -(put 'inline 'lisp-indent-function 0) ;;; Interface to inline functions. @@ -292,5 +291,4 @@ In interpreted code, this is entirely equivalent to `progn'." ;; (file-format emacs19))" ;; nil) -;; arch-tag: 76f8328a-1f66-4df2-9b6d-5c3666dc05e9 ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 86cfaff77ba..199927d536e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,12 +1,13 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code -;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011 +;; Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: lisp +;; Package: emacs ;; This file is part of GNU Emacs. @@ -35,6 +36,7 @@ ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, +;; byte-recompile-file, ;; batch-byte-compile, batch-byte-recompile-directory, ;; byte-compile, compile-defun, ;; display-call-tree @@ -245,10 +247,14 @@ This option is enabled by default because it reduces Emacs memory usage." :type 'boolean) ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) +(defconst byte-compile-log-buffer "*Compile-Log*" + "Name of the byte-compiler's log buffer.") + (defcustom byte-optimize-log nil - "If true, the byte-compiler will log its optimizations into *Compile-Log*. + "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 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) (const :tag "all" t) @@ -263,7 +269,7 @@ If it is 'byte, then only byte-level optimizations will be logged." (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious) + make-local mapcar constants suspicious lexical) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -873,7 +879,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; Log something that isn't a warning. (defun byte-compile-log-1 (string) - (with-current-buffer "*Compile-Log*" + (with-current-buffer byte-compile-log-buffer (let ((inhibit-read-only t)) (goto-char (point-max)) (byte-compile-warning-prefix nil nil) @@ -981,13 +987,13 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; (compile-mode) will cause this to be loaded. (declare-function compilation-forget-errors "compile" ()) -;; Log the start of a file in *Compile-Log*, and mark it as done. +;; Log the start of a file in `byte-compile-log-buffer', and mark it as done. ;; Return the position of the start of the page in the log buffer. ;; But do nothing in batch mode. (defun byte-compile-log-file () (and (not (equal byte-compile-current-file byte-compile-last-logged-file)) (not noninteractive) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (goto-char (point-max)) (let* ((inhibit-read-only t) (dir (and byte-compile-current-file @@ -1018,14 +1024,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (compilation-forget-errors) pt)))) -;; Log a message STRING in *Compile-Log*. +;; 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) (let ((warning-prefix-function 'byte-compile-warning-prefix) (warning-type-format "") (warning-fill-prefix (if fill " ")) (inhibit-read-only t)) - (display-warning 'bytecomp string level "*Compile-Log*"))) + (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." @@ -1332,7 +1338,7 @@ extra args." (not (and (eq (get func 'byte-compile) 'cl-byte-compile-compiler-macro) (string-match "\\`c[ad]+r\\'" (symbol-name func))))) - (byte-compile-warn "Function `%s' from cl package called at runtime" + (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1441,7 +1447,7 @@ symbol itself." (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer "*Compile-Log*"))))) + (get-buffer byte-compile-log-buffer))))) (byte-compile-find-cl-functions) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) @@ -1503,7 +1509,7 @@ that already has a `.elc' file." nil (save-some-buffers) (force-mode-line-update)) - (with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create byte-compile-log-buffer) (setq default-directory (expand-file-name bytecomp-directory)) ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) @@ -1538,22 +1544,12 @@ that already has a `.elc' file." (if (and (string-match emacs-lisp-file-regexp bytecomp-source) (file-readable-p bytecomp-source) (not (auto-save-file-name-p bytecomp-source)) - (setq bytecomp-dest - (byte-compile-dest-file bytecomp-source)) - (if (file-exists-p bytecomp-dest) - ;; File was already compiled. - (or bytecomp-force - (file-newer-than-file-p bytecomp-source - bytecomp-dest)) - ;; No compiled file exists yet. - (and bytecomp-arg - (or (eq 0 bytecomp-arg) - (y-or-n-p (concat "Compile " - bytecomp-source "? ")))))) - (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." bytecomp-source)) - (let ((bytecomp-res (byte-compile-file - bytecomp-source))) + (not (string-equal dir-locals-file + (file-name-nondirectory + bytecomp-source)))) + (progn (let ((bytecomp-res (byte-recompile-file + bytecomp-source + bytecomp-force bytecomp-arg))) (cond ((eq bytecomp-res 'no-byte-compile) (setq skip-count (1+ skip-count))) ((eq bytecomp-res t) @@ -1581,6 +1577,60 @@ This is normally set in local file variables at the end of the elisp file: ;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) +(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) + "Recompile BYTECOMP-FILENAME file if it needs recompilation. +This happens when its `.elc' file is older than itself. + +If the `.elc' file exists and is up-to-date, normally this +function *does not* compile BYTECOMP-FILENAME. However, if the +prefix argument BYTECOMP-FORCE is set, that means do compile +BYTECOMP-FILENAME even if the destination already exists and is +up-to-date. + +If the `.elc' file does not exist, normally this function *does +not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means +compile the file even if it has never been compiled before. +A nonzero BYTECOMP-ARG means ask the user. + +If LOAD is set, `load' the file after compiling. + +The value returned is the value returned by `byte-compile-file', +or 'no-byte-compile if the file did not need recompilation." + (interactive + (let ((bytecomp-file buffer-file-name) + (bytecomp-file-name nil) + (bytecomp-file-dir nil)) + (and bytecomp-file + (eq (cdr (assq 'major-mode (buffer-local-variables))) + 'emacs-lisp-mode) + (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) + bytecomp-file-dir (file-name-directory bytecomp-file))) + (list (read-file-name (if current-prefix-arg + "Byte compile file: " + "Byte recompile file: ") + bytecomp-file-dir bytecomp-file-name nil) + current-prefix-arg))) + (let ((bytecomp-dest + (byte-compile-dest-file bytecomp-filename)) + ;; Expand now so we get the current buffer's defaults + (bytecomp-filename (expand-file-name bytecomp-filename))) + (if (if (file-exists-p bytecomp-dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or bytecomp-force + (file-newer-than-file-p bytecomp-filename + bytecomp-dest)) + (and bytecomp-arg + (or (eq 0 bytecomp-arg) + (y-or-n-p (concat "Compile " + bytecomp-filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." bytecomp-filename)) + (byte-compile-file bytecomp-filename load)) + (when load (load bytecomp-filename)) + 'no-byte-compile))) + ;;;###autoload (defun byte-compile-file (bytecomp-filename &optional load) "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. @@ -1684,17 +1734,28 @@ The value is non-nil if there were no errors, nil if errors." (insert "\n") ; aaah, unix. (if (file-writable-p target-file) ;; We must disable any code conversion here. - (let ((coding-system-for-write 'no-conversion)) + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile (make-temp-name target-file)) + (kill-emacs-hook + (cons (lambda () (ignore-errors (delete-file tempfile))) + kill-emacs-hook))) (if (memq system-type '(ms-dos 'windows-nt)) (setq buffer-file-type t)) - (when (file-exists-p target-file) - ;; Remove the target before writing it, so that any - ;; hard-links continue to point to the old file (this makes - ;; it possible for installed files to share disk space with - ;; the build tree, without causing problems when emacs-lisp - ;; files in the build tree are recompiled). - (delete-file target-file)) - (write-region (point-min) (point-max) target-file)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (rename-file tempfile target-file t) + (message "Wrote %s" target-file)) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" @@ -1775,14 +1836,7 @@ With argument ARG, insert value in current buffer after the form." (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) - (setq case-fold-search nil) - ;; This is a kludge. Some operating systems (OS/2, DOS) need to - ;; write files containing binary information specially. - ;; Under most circumstances, such files will be in binary - ;; overwrite mode, so those OS's use that flag to guess how - ;; they should write their data. Advise them that .elc files - ;; need to be written carefully. - (setq overwrite-mode 'overwrite-mode-binary)) + (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer bytecomp-inbuffer (and bytecomp-filename @@ -2003,9 +2057,9 @@ list that represents a doc string reference. ;; to objects already output ;; (for instance, gensyms in the arg list). (let (non-nil) - (dotimes (i (length print-number-table)) - (if (aref print-number-table i) - (setq non-nil t))) + (when (hash-table-p print-number-table) + (maphash (lambda (k v) (if v (setq non-nil t))) + print-number-table)) (not non-nil))) ;; Output the byte code and constants specially ;; for lazy dynamic loading. @@ -2131,6 +2185,11 @@ list that represents a doc string reference. ;; Since there is no doc string, we can compile this as a normal form, ;; and not do a file-boundary. (byte-compile-keep-pending form) + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (push (nth 1 form) byte-compile-bound-variables) (if (eq (car form) 'defconst) (push (nth 1 form) byte-compile-const-variables)) @@ -3324,21 +3383,31 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (setq for-effect nil))) (defun byte-compile-setq-default (form) - (let ((bytecomp-args (cdr form)) - setters) - (while bytecomp-args - (let ((var (car bytecomp-args))) - (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) - (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - "variable assignment to %s `%s'" - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))) - (push (list 'set-default (list 'quote var) (car (cdr bytecomp-args))) - setters)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) - (byte-compile-form (cons 'progn (nreverse setters))))) + (setq form (cdr form)) + (if (> (length form) 2) + (let ((setters ())) + (while (consp form) + (push `(setq-default ,(pop form) ,(pop form)) setters)) + (byte-compile-form (cons 'progn (nreverse setters)))) + (let ((var (car form))) + (and (or (not (symbolp var)) + (byte-compile-const-symbol-p var t)) + (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn + "variable assignment to %s `%s'" + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var))) + (byte-compile-normal-call `(set-default ',var ,@(cdr form)))))) + +(byte-defop-compiler-1 set-default) +(defun byte-compile-set-default (form) + (let ((varexp (car-safe (cdr-safe form)))) + (if (eq (car-safe varexp) 'quote) + ;; If the varexp is constant, compile it as a setq-default + ;; so we get more warnings. + (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp)) + ,@(cddr form))) + (byte-compile-normal-call form)))) (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) @@ -3772,6 +3841,11 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) @@ -4220,6 +4294,8 @@ and corresponding effects." (defvar byte-code-meter) (defun byte-compile-report-ops () + (or (boundp 'byte-metering-on) + (error "You must build Emacs with -DBYTE_CODE_METER to use this")) (with-output-to-temp-buffer "*Meter*" (set-buffer "*Meter*") (let ((i 0) n op off) @@ -4268,5 +4344,4 @@ and corresponding effects." (run-hooks 'bytecomp-load-hook) -;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a ;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index ace94c2bc6d..01eb1efdc3b 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,6 +1,6 @@ ;;; chart.el --- Draw charts (bar charts, etc) -;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010, 2011 +;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2011 ;; Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -62,21 +62,13 @@ (require 'eieio) ;;; Code: -(defvar chart-map nil "Keymap used in chart mode.") -(if chart-map - () - (setq chart-map (make-sparse-keymap)) - ) +(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") +(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") (make-variable-buffer-local 'chart-local-object) -(defvar chart-face-list nil - "Faces used to colorize charts. -List is limited currently, which is ok since you really can't display -too much in text characters anyways.") - (defvar chart-face-color-list '("red" "green" "blue" "cyan" "yellow" "purple") "Colors to use when generating `chart-face-list'. @@ -94,41 +86,42 @@ Useful if new Emacs is used on B&W display.") :group 'eieio :type 'boolean) -(if (and (if (fboundp 'display-color-p) - (display-color-p) - window-system) - (not chart-face-list)) - (let ((cl chart-face-color-list) - (pl chart-face-pixmap-list) - nf) - (while cl - (setq nf (make-face (intern (concat "chart-" (car cl) "-" (car pl))))) - (if (condition-case nil - (> (x-display-color-cells) 4) - (error t)) - (set-face-background nf (car cl)) - (set-face-background nf "white")) - (set-face-foreground nf "black") - (if (and chart-face-use-pixmaps - pl - (fboundp 'set-face-background-pixmap)) - (condition-case nil - (set-face-background-pixmap nf (car pl)) - (error (message "Cannot set background pixmap %s" (car pl))))) - (setq chart-face-list (cons nf chart-face-list)) - (setq cl (cdr cl) - pl (cdr pl))))) - -(defun chart-mode () +(defvar chart-face-list + (if (if (fboundp 'display-color-p) + (display-color-p) + window-system) + (let ((cl chart-face-color-list) + (pl chart-face-pixmap-list) + (faces ()) + nf) + (while cl + (setq nf (make-face + (intern (concat "chart-" (car cl) "-" (car pl))))) + (set-face-background nf (if (condition-case nil + (> (x-display-color-cells) 4) + (error t)) + (car cl) + "white")) + (set-face-foreground nf "black") + (if (and chart-face-use-pixmaps + pl + (fboundp 'set-face-background-pixmap)) + (condition-case nil + (set-face-background-pixmap nf (car pl)) + (error (message "Cannot set background pixmap %s" (car pl))))) + (push nf faces) + (setq cl (cdr cl) + pl (cdr pl))) + faces)) + "Faces used to colorize charts. +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 a mode in Emacs for displaying a chart." - (kill-all-local-variables) - (use-local-map chart-map) - (setq major-mode 'chart-mode - mode-name "CHART") (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) - (font-lock-mode -1) - (run-hooks 'chart-mode-hook) + (font-lock-mode -1) ;Isn't it off already? --Stef ) (defun chart-new-buffer (obj) @@ -529,9 +522,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details." (defun chart-zap-chars (n) "Zap up to N chars without deleting EOLs." (if (not (eobp)) - (if (< n (- (save-excursion (end-of-line) (point)) (point))) + (if (< n (- (point-at-eol) (point))) (delete-char n) - (delete-region (point) (save-excursion (end-of-line) (point)))))) + (delete-region (point) (point-at-eol))))) (defun chart-display-label (label dir zone start end &optional face) "Display LABEL in direction DIR in column/row ZONE between START and END. @@ -750,5 +743,4 @@ SORT-PRED if desired." (provide 'chart) -;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59 ;;; chart.el ends here diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index a84be940564..f6ff67a90c3 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, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2007-2011 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> ;; Keywords: lisp, tools, maint @@ -314,5 +314,4 @@ Returns non-nil if any false statements are found." (provide 'check-declare) -;; arch-tag: a4d6cdc4-deb7-4502-b327-0e4ef3d82d96 ;;; check-declare.el ends here. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 6726e83c77b..2d3b228cbd4 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,7 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1997-1998, 2001-2011 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -201,9 +200,9 @@ without asking, and complex changes are made by asking the user first. The value `never' is the same as nil, never ask or change anything." :group 'checkdoc :type '(choice (const automatic) - (const query) - (const never) - (other :tag "semiautomatic" semiautomatic))) + (const query) + (const never) + (other :tag "semiautomatic" semiautomatic))) (defcustom checkdoc-bouncy-flag t "Non-nil means to \"bounce\" to auto-fix locations. @@ -250,10 +249,10 @@ system. Possible values are: t - Always spell-check" :group 'checkdoc :type '(choice (const nil) - (const defun) - (const buffer) - (const interactive) - (const t))) + (const defun) + (const buffer) + (const interactive) + (const t))) (defvar checkdoc-ispell-lisp-words '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") @@ -429,19 +428,15 @@ and experimental check. Do not modify this list without setting the value of `checkdoc-common-verbs-regexp' to nil which cause it to be re-created.") -(defvar checkdoc-syntax-table nil +(defvar checkdoc-syntax-table + (let ((st (make-syntax-table emacs-lisp-mode-syntax-table))) + ;; When dealing with syntax in doc strings, make sure that - are + ;; encompassed in words so we can use cheap \\> to get the end of a symbol, + ;; not the end of a word in a conglomerate. + (modify-syntax-entry ?- "w" st) + st) "Syntax table used by checkdoc in document strings.") -(if checkdoc-syntax-table - nil - (setq checkdoc-syntax-table (copy-syntax-table emacs-lisp-mode-syntax-table)) - ;; When dealing with syntax in doc strings, make sure that - are encompassed - ;; in words so we can use cheap \\> to get the end of a symbol, not the - ;; end of a word in a conglomerate. - (modify-syntax-entry ?- "w" checkdoc-syntax-table) - ) - - ;;; Compatibility ;; (defalias 'checkdoc-make-overlay @@ -515,12 +510,11 @@ CHECK is a list of four strings stating the current status of each test; the nth string describes the status of the nth test." (let (temp-buffer-setup-hook) (with-output-to-temp-buffer "*Checkdoc Status*" - (princ-list - "Buffer comments and tags: " (nth 0 check) "\n" - "Documentation style: " (nth 1 check) "\n" - "Message/Query text style: " (nth 2 check) "\n" - "Unwanted Spaces: " (nth 3 check) - ))) + (mapc #'princ + (list "Buffer comments and tags: " (nth 0 check) + "\nDocumentation style: " (nth 1 check) + "\nMessage/Query text style: " (nth 2 check) + "\nUnwanted Spaces: " (nth 3 check))))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Status*")) (message nil) @@ -623,7 +617,7 @@ style." (recenter (/ (- (window-height) l) 2)))) (recenter)) (message "%s (C-h,%se,n,p,q)" (checkdoc-error-text - (car (car err-list))) + (car (car err-list))) (if (checkdoc-error-unfixable (car (car err-list))) "" "f,")) (save-excursion @@ -713,20 +707,21 @@ style." (delete-window (get-buffer-window "*Checkdoc Help*")) (kill-buffer "*Checkdoc Help*")) (with-output-to-temp-buffer "*Checkdoc Help*" - (princ-list - "Checkdoc Keyboard Summary:\n" - (if (checkdoc-error-unfixable (car (car err-list))) - "" - (concat - "f, y - auto Fix this warning without asking (if\ + (with-current-buffer standard-output + (insert + "Checkdoc Keyboard Summary:\n" + (if (checkdoc-error-unfixable (car (car err-list))) + "" + (concat + "f, y - auto Fix this warning without asking (if\ available.)\n" - " Very complex operations will still query.\n") - ) - "e - Enter recursive Edit. Press C-M-c to exit.\n" - "SPC, n - skip to the Next error.\n" - "DEL, p - skip to the Previous error.\n" - "q - Quit checkdoc.\n" - "C-h - Toggle this help buffer.")) + " Very complex operations will still query.\n") + ) + "e - Enter recursive Edit. Press C-M-c to exit.\n" + "SPC, n - skip to the Next error.\n" + "DEL, p - skip to the Previous error.\n" + "q - Quit checkdoc.\n" + "C-h - Toggle this help buffer."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")))))) (if cdo (checkdoc-delete-overlay cdo))))) @@ -826,9 +821,9 @@ assumes that the cursor is already positioned to perform the fix." "Enter recursive edit to permit a user to fix some error checkdoc has found. MSG is the error that was found, which is displayed in a help buffer." (with-output-to-temp-buffer "*Checkdoc Help*" - (princ-list - "Error message:\n " msg - "\n\nEdit to fix this problem, and press C-M-c to continue.")) + (mapc #'princ + (list "Error message:\n " msg + "\n\nEdit to fix this problem, and press C-M-c to continue."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")) (message "When you're done editing press C-M-c to continue.") @@ -947,14 +942,14 @@ if there is one." (interactive "P") (if take-notes (checkdoc-start-section "checkdoc-comments")) (if (not buffer-file-name) - (error "Can only check comments for a file buffer")) + (error "Can only check comments for a file buffer")) (let* ((checkdoc-spellcheck-documentation-flag (car (memq checkdoc-spellcheck-documentation-flag '(buffer t)))) (checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag)) (e (checkdoc-file-comments-engine)) - (checkdoc-generate-compile-warnings-flag - (or take-notes checkdoc-generate-compile-warnings-flag))) + (checkdoc-generate-compile-warnings-flag + (or take-notes checkdoc-generate-compile-warnings-flag))) (if e (error "%s" (checkdoc-error-text e))) (checkdoc-show-diagnostics) e)) @@ -970,8 +965,8 @@ Optional argument INTERACT permits more interactive fixing." (if take-notes (checkdoc-start-section "checkdoc-rogue-spaces")) (let* ((checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag)) (e (checkdoc-rogue-space-check-engine nil nil interact)) - (checkdoc-generate-compile-warnings-flag - (or take-notes checkdoc-generate-compile-warnings-flag))) + (checkdoc-generate-compile-warnings-flag + (or take-notes checkdoc-generate-compile-warnings-flag))) (if (not (called-interactively-p 'interactive)) e (if e @@ -1207,40 +1202,37 @@ generating a buffered list of errors." map) "Keymap used to override evaluation key-bindings for documentation checking.") -(define-obsolete-variable-alias 'checkdoc-minor-keymap - 'checkdoc-minor-mode-map "21.1") - ;; Add in a menubar with easy-menu (easy-menu-define - nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu" - '("CheckDoc" - ["Interactive Buffer Style Check" checkdoc t] - ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t] - ["Check Buffer" checkdoc-current-buffer t] - ["Check and Spell Buffer" checkdoc-ispell-current-buffer t] - "---" - ["Interactive Style Check" checkdoc-interactive t] - ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t] - ["Find First Style Error" checkdoc-start t] - ["Find First Style or Spelling Error" checkdoc-ispell-start t] - ["Next Style Error" checkdoc-continue t] - ["Next Style or Spelling Error" checkdoc-ispell-continue t] - ["Interactive Message Text Style Check" checkdoc-message-interactive t] - ["Interactive Message Text Style and Spelling Check" - checkdoc-ispell-message-interactive t] - ["Check Message Text" checkdoc-message-text t] - ["Check and Spell Message Text" checkdoc-ispell-message-text t] - ["Check Comment Style" checkdoc-comments buffer-file-name] - ["Check Comment Style and Spelling" checkdoc-ispell-comments - buffer-file-name] - ["Check for Rogue Spaces" checkdoc-rogue-spaces t] - "---" - ["Check Defun" checkdoc-defun t] - ["Check and Spell Defun" checkdoc-ispell-defun t] - ["Check and Evaluate Defun" checkdoc-eval-defun t] - ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t] - )) + nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu" + '("CheckDoc" + ["Interactive Buffer Style Check" checkdoc t] + ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t] + ["Check Buffer" checkdoc-current-buffer t] + ["Check and Spell Buffer" checkdoc-ispell-current-buffer t] + "---" + ["Interactive Style Check" checkdoc-interactive t] + ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t] + ["Find First Style Error" checkdoc-start t] + ["Find First Style or Spelling Error" checkdoc-ispell-start t] + ["Next Style Error" checkdoc-continue t] + ["Next Style or Spelling Error" checkdoc-ispell-continue t] + ["Interactive Message Text Style Check" checkdoc-message-interactive t] + ["Interactive Message Text Style and Spelling Check" + checkdoc-ispell-message-interactive t] + ["Check Message Text" checkdoc-message-text t] + ["Check and Spell Message Text" checkdoc-ispell-message-text t] + ["Check Comment Style" checkdoc-comments buffer-file-name] + ["Check Comment Style and Spelling" checkdoc-ispell-comments + buffer-file-name] + ["Check for Rogue Spaces" checkdoc-rogue-spaces t] + "---" + ["Check Defun" checkdoc-defun t] + ["Check and Spell Defun" checkdoc-ispell-defun t] + ["Check and Evaluate Defun" checkdoc-eval-defun t] + ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t] + )) ;; XEmacs requires some weird stuff to add this menu in a minor mode. ;; What is it? @@ -1369,7 +1361,7 @@ See the style guide in the Emacs Lisp manual for more details." (setq checkdoc-autofix-flag 'never)))) (checkdoc-create-error "You should convert this comment to documentation" - (point) (save-excursion (end-of-line) (point)))) + (point) (line-end-position))) (checkdoc-create-error (if (nth 2 fp) "All interactive functions should have documentation" @@ -1377,12 +1369,8 @@ See the style guide in the Emacs Lisp manual for more details." documentation string") (point) (+ (point) 1) t))))) (if (and (not err) (looking-at "\"")) - (let ((old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (checkdoc-this-string-valid-engine fp)) - (set-syntax-table old-syntax-table))) + (with-syntax-table checkdoc-syntax-table + (checkdoc-this-string-valid-engine fp)) err))) (defun checkdoc-this-string-valid-engine (fp) @@ -1391,7 +1379,7 @@ Depends on `checkdoc-this-string-valid' to reset the syntax table so that regexp short cuts work. FP is the function defun information." (let ((case-fold-search nil) ;; Use a marker so if an early check modifies the text, - ;; we won't accidentally loose our place. This could cause + ;; we won't accidentally lose our place. This could cause ;; end-of doc string whitespace to also delete the " char. (s (point)) (e (if (looking-at "\"") @@ -1489,12 +1477,10 @@ regexp short cuts work. FP is the function defun information." "First line not a complete sentence. Add RET here? " "\n" t) (let (l1 l2) - (forward-line 1) - (end-of-line) + (end-of-line 2) (setq l1 (current-column) l2 (save-excursion - (forward-line 1) - (end-of-line) + (end-of-line 2) (current-column))) (if (> (+ l1 l2 1) 80) (setq msg "Incomplete auto-fix; doc string \ @@ -1511,10 +1497,7 @@ may require more formatting") (forward-line 1) (beginning-of-line) (if (and (re-search-forward "[.!?:\"]\\([ \t\n]+\\|\"\\)" - (save-excursion - (end-of-line) - (point)) - t) + (line-end-position) t) (< (current-column) numc)) (if (checkdoc-autofix-ask-replace p (1+ p) @@ -1529,9 +1512,7 @@ may require more formatting") (if msg (checkdoc-create-error msg s (save-excursion (goto-char s) - (end-of-line) - (point))) - nil) )))) + (line-end-position)))))))) ;; Continuation of above. Make sure our sentence is capitalized. (save-excursion (skip-chars-forward "\"\\*") @@ -1631,7 +1612,7 @@ function,command,variable,option or symbol." ms1)))))) (if (and (< (point) e) (> (current-column) 80)) (checkdoc-create-error "Some lines are over 80 columns wide" - s (save-excursion (goto-char s) (end-of-line) (point)) )))) + s (save-excursion (goto-char s) (line-end-position)))))) ;; Here we deviate to tests based on a variable or function. ;; We must do this before checking for symbols in quotes because there ;; is a chance that just such a symbol might really be an argument. @@ -1776,9 +1757,8 @@ function,command,variable,option or symbol." ms1)))))) (end-of-line) ;; check string-continuation (if (checkdoc-char= (preceding-char) ?\\) - (progn (forward-line 1) - (end-of-line))) - (point))) + (line-end-position 2) + (point)))) (rs nil) replace original (case-fold-search t)) (while (and (not rs) (re-search-forward @@ -2004,49 +1984,45 @@ internally skip over no answers. If the offending word is in a piece of quoted text, then it is skipped." (save-excursion (let ((case-fold-search nil) - (errtxt nil) bb be - (old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (goto-char begin) - (while (re-search-forward checkdoc-proper-noun-regexp end t) - (let ((text (match-string 1)) - (b (match-beginning 1)) - (e (match-end 1))) - (if (and (not (save-excursion - (goto-char b) - (forward-char -1) - (looking-at "`\\|\"\\|\\.\\|\\\\"))) - ;; surrounded by /, as in a URL or filename: /emacs/ - (not (and (= ?/ (char-after e)) - (= ?/ (char-before b)))) - (not (checkdoc-in-example-string-p begin end)) - ;; info or url links left alone - (not (thing-at-point-looking-at - help-xref-info-regexp)) - (not (thing-at-point-looking-at - help-xref-url-regexp))) - (if (checkdoc-autofix-ask-replace - b e (format "Text %s should be capitalized. Fix? " - text) - (capitalize text) t) - nil - (if errtxt - ;; If there is already an error, then generate - ;; the warning output if applicable - (if checkdoc-generate-compile-warnings-flag - (checkdoc-create-error - (format - "Name %s should appear capitalized as %s" - text (capitalize text)) - b e)) - (setq errtxt - (format - "Name %s should appear capitalized as %s" - text (capitalize text)) - bb b be e))))))) - (set-syntax-table old-syntax-table)) + (errtxt nil) bb be) + (with-syntax-table checkdoc-syntax-table + (goto-char begin) + (while (re-search-forward checkdoc-proper-noun-regexp end t) + (let ((text (match-string 1)) + (b (match-beginning 1)) + (e (match-end 1))) + (if (and (not (save-excursion + (goto-char b) + (forward-char -1) + (looking-at "`\\|\"\\|\\.\\|\\\\"))) + ;; surrounded by /, as in a URL or filename: /emacs/ + (not (and (= ?/ (char-after e)) + (= ?/ (char-before b)))) + (not (checkdoc-in-example-string-p begin end)) + ;; info or url links left alone + (not (thing-at-point-looking-at + help-xref-info-regexp)) + (not (thing-at-point-looking-at + help-xref-url-regexp))) + (if (checkdoc-autofix-ask-replace + b e (format "Text %s should be capitalized. Fix? " + text) + (capitalize text) t) + nil + (if errtxt + ;; If there is already an error, then generate + ;; the warning output if applicable + (if checkdoc-generate-compile-warnings-flag + (checkdoc-create-error + (format + "Name %s should appear capitalized as %s" + text (capitalize text)) + b e)) + (setq errtxt + (format + "Name %s should appear capitalized as %s" + text (capitalize text)) + bb b be e))))))) (if errtxt (checkdoc-create-error errtxt bb be))))) (defun checkdoc-sentencespace-region-engine (begin end) @@ -2054,43 +2030,39 @@ If the offending word is in a piece of quoted text, then it is skipped." (if sentence-end-double-space (save-excursion (let ((case-fold-search nil) - (errtxt nil) bb be - (old-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table checkdoc-syntax-table) - (goto-char begin) - (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t) - (let ((b (match-beginning 1)) - (e (match-end 1))) - (unless (or (checkdoc-in-sample-code-p begin end) - (checkdoc-in-example-string-p begin end) - (save-excursion - (goto-char b) - (condition-case nil - (progn - (forward-sexp -1) - ;; piece of an abbreviation - ;; FIXME etc - (looking-at - "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\.")) - (error t)))) - (if (checkdoc-autofix-ask-replace - b e - "There should be two spaces after a period. Fix? " - ". ") - nil - (if errtxt - ;; If there is already an error, then generate - ;; the warning output if applicable - (if checkdoc-generate-compile-warnings-flag - (checkdoc-create-error - "There should be two spaces after a period" - b e)) - (setq errtxt - "There should be two spaces after a period" - bb b be e))))))) - (set-syntax-table old-syntax-table)) + (errtxt nil) bb be) + (with-syntax-table checkdoc-syntax-table + (goto-char begin) + (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t) + (let ((b (match-beginning 1)) + (e (match-end 1))) + (unless (or (checkdoc-in-sample-code-p begin end) + (checkdoc-in-example-string-p begin end) + (save-excursion + (goto-char b) + (condition-case nil + (progn + (forward-sexp -1) + ;; piece of an abbreviation + ;; FIXME etc + (looking-at + "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\.")) + (error t)))) + (if (checkdoc-autofix-ask-replace + b e + "There should be two spaces after a period. Fix? " + ". ") + nil + (if errtxt + ;; If there is already an error, then generate + ;; the warning output if applicable + (if checkdoc-generate-compile-warnings-flag + (checkdoc-create-error + "There should be two spaces after a period" + b e)) + (setq errtxt + "There should be two spaces after a period" + bb b be e))))))) (if errtxt (checkdoc-create-error errtxt bb be)))))) ;;; Ispell engine @@ -2258,8 +2230,8 @@ Code:, and others referenced in the style guide." (insert ";;; " fn fe " --- " (read-string "Summary: ") "\n")) (checkdoc-create-error "The first line should be of the form: \";;; package --- Summary\"" - (point-min) (save-excursion (goto-char (point-min)) (end-of-line) - (point)))) + (point-min) (save-excursion (goto-char (point-min)) + (line-end-position)))) nil)) (setq err @@ -2670,8 +2642,7 @@ function called to create the messages." (setq checkdoc-pending-errors nil) nil))) -(custom-add-option 'emacs-lisp-mode-hook - (lambda () (checkdoc-minor-mode 1))) +(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) (add-to-list 'debug-ignored-errors "Argument `.*' should appear (as .*) in the doc string") @@ -2681,5 +2652,4 @@ function called to create the messages." (provide 'checkdoc) -;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26 ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 4c633eeba4e..885424ec726 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,10 +1,10 @@ ;;; cl-extra.el --- Common Lisp features, part 2 -;; Copyright (C) 1993, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2011 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -685,7 +685,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (setq last (point)) (goto-char (1+ pt)) (while (search-forward "(quote " last t) - (delete-backward-char 7) + (delete-char -7) (insert "'") (forward-sexp) (delete-char 1)) @@ -825,5 +825,4 @@ This also does some trivial optimizations to make the form prettier." ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed ;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index cbf35f3e7d4..787f276ecae 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -1,12 +1,12 @@ ;;; cl-indent.el --- enhanced lisp-indent mode -;; Copyright (C) 1987, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc. ;; Author: Richard Mlynarik <mly@eddie.mit.edu> ;; Created: July 1987 ;; Maintainer: FSF ;; Keywords: lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. @@ -690,5 +690,4 @@ For example, the function `case' has an indent property ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) -;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03 ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index e6ede1ed6d4..05bfa0f262e 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "de874ef326082f133b0324505ad37330") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -277,12 +277,12 @@ Not documented ;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct ;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf ;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method -;;;;;; declare the locally multiple-value-setq multiple-value-bind -;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels -;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist -;;;;;; do* do loop return-from return block etypecase typecase ecase -;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fd4df570f1dcbf83cde740819ae3734a") +;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let* +;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq +;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from +;;;;;; return block etypecase typecase ecase case load-time-value +;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp +;;;;;; gensym) "cl-macs" "cl-macs.el" "8b2ce9c2ec0e273606bb37c333c4bdde") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -535,11 +535,6 @@ Not documented \(fn &rest BODY)" nil (quote macro)) -(autoload 'the "cl-macs" "\ -Not documented - -\(fn TYPE FORM)" nil (quote macro)) - (autoload 'declare "cl-macs" "\ Not documented @@ -759,7 +754,7 @@ surrounded by (block NAME ...). ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "ac5c427e92a38c5a2149acaa013caad9") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "43e0c1183e738e1e1038cdd84fde8366") ;;; Generated autoloads from cl-seq.el (autoload 'reduce "cl-seq" "\ @@ -1242,7 +1237,6 @@ Keywords supported: :test :test-not :key ;; version-control: never ;; no-byte-compile: t ;; no-update-autoloads: t +;; coding: utf-8 ;; End: - -;; arch-tag: 08cc5aab-e992-47f6-992e-12a7428c1a0e ;;; cl-loaddefs.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 94c2312541c..bef334b544c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,11 +1,11 @@ ;;; cl-macs.el --- Common Lisp macros -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -128,6 +128,12 @@ (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) + ;; This apparently tries to return nil iff the expression X evaluates + ;; the variables V in the same order as they appear in V (so as to + ;; be able to replace those vars with the expressions they're bound + ;; to). + ;; FIXME: This is very naive, it doesn't even check to see if those + ;; variables appear more than once. (if (cl-const-expr-p x) v (if (consp x) (progn @@ -632,7 +638,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "loop" macro. -(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) +(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars) (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) (defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) (defvar loop-initially) (defvar loop-map-form) (defvar loop-name) @@ -640,7 +646,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest args) +(defmacro loop (&rest loop-args) "The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -655,8 +661,8 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) + (list 'block nil (list* 'while t loop-args)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) @@ -665,8 +671,8 @@ Valid clauses are: (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) - (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) + (setq loop-args (append loop-args '(cl-end-loop))) + (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) (if loop-finish-flag (push `((,loop-finish-flag t)) loop-bindings)) (if loop-first-flag @@ -706,34 +712,34 @@ Valid clauses are: (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) -(defun cl-parse-loop-clause () ; uses args, loop-* - (let ((word (pop args)) +(defun cl-parse-loop-clause () ; uses loop-* + (let ((word (pop loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null args) + ((null loop-args) (error "Malformed `loop' macro")) ((eq word 'named) - (setq loop-name (pop args))) + (setq loop-name (pop loop-args))) ((eq word 'initially) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (push (pop args) loop-initially))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car loop-args)) + (push (pop loop-args) loop-initially))) ((eq word 'finally) - (if (eq (car args) 'return) - (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil))) - (while (consp (car args)) - (push (pop args) loop-finally))))) + (if (eq (car loop-args) 'return) + (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar loop-args) 'return) (null loop-name)) + (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil))) + (while (consp (car loop-args)) + (push (pop loop-args) loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) @@ -742,29 +748,29 @@ Valid clauses are: ;; Use `gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop args) (gensym "--cl-var--")))) - (setq word (pop args)) - (if (eq word 'being) (setq word (pop args))) - (if (memq word '(the each)) (setq word (pop args))) + (let ((var (or (pop loop-args) (gensym "--cl-var--")))) + (setq word (pop loop-args)) + (if (eq word 'being) (setq word (pop loop-args))) + (if (memq word '(the each)) (setq word (pop loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) + (setq word 'in loop-args (cons '(buffer-list) loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word args) - (if (memq (car args) '(downto above)) + (push word loop-args) + (if (memq (car loop-args) '(downto above)) (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car args) 'downfrom) - (memq (caddr args) '(downto above)))) - (excl (or (memq (car args) '(above below)) - (memq (caddr args) '(above below)))) - (start (and (memq (car args) '(from upfrom downfrom)) - (cl-pop2 args))) - (end (and (memq (car args) + (let* ((down (or (eq (car loop-args) 'downfrom) + (memq (caddr loop-args) '(downto above)))) + (excl (or (memq (car loop-args) '(above below)) + (memq (caddr loop-args) '(above below)))) + (start (and (memq (car loop-args) '(from upfrom downfrom)) + (cl-pop2 loop-args))) + (end (and (memq (car loop-args) '(to upto downto above below)) - (cl-pop2 args))) - (step (and (eq (car args) 'by) (cl-pop2 args))) + (cl-pop2 loop-args))) + (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args))) (end-var (and (not (cl-const-expr-p end)) (make-symbol "--cl-var--"))) (step-var (and (not (cl-const-expr-p step)) @@ -787,7 +793,7 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop args)) loop-for-bindings) + (push (list temp (pop loop-args)) loop-for-bindings) (push (list 'consp temp) loop-body) (if (eq word 'in-ref) (push (list var (list 'car temp)) loop-symbol-macs) @@ -797,8 +803,8 @@ Valid clauses are: (push (list var (if on temp (list 'car temp))) loop-for-sets)))) (push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) + (if (eq (car loop-args) 'by) + (let ((step (cl-pop2 loop-args))) (if (and (memq (car-safe step) '(quote function function*)) @@ -809,10 +815,10 @@ Valid clauses are: loop-for-steps))) ((eq word '=) - (let* ((start (pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) + (let* ((start (pop loop-args)) + (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) + (if (or ands (eq (car loop-args) 'and)) (progn (push `(,var (if ,(or loop-first-flag @@ -832,7 +838,7 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop args)) loop-for-bindings) + (push (list temp-vec (pop loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) (list 'length temp-vec)) loop-body) @@ -844,15 +850,15 @@ Valid clauses are: loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car args) '(in-ref of-ref)) - (and (not (memq (car args) '(in of))) + (let ((ref (or (memq (car loop-args) '(in-ref of-ref)) + (and (not (memq (car loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 args)) + (seq (cl-pop2 loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) + (temp-idx (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (eq (caadr loop-args) 'index)) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -878,13 +884,13 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) hash-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) hash-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) @@ -894,16 +900,16 @@ Valid clauses are: ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) + (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))) (setq loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car args) '(in of from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (setq loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) @@ -914,12 +920,12 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car args) '(in of property from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - ((eq (car args) 'property) - (setq prop (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of property from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + ((eq (car loop-args) 'property) + (setq prop (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var (list 'cons var1 var2)) loop-for-sets)) @@ -929,13 +935,13 @@ Valid clauses are: ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) key-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let ((map (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) key-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) @@ -957,17 +963,26 @@ Valid clauses are: loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) - (temp (make-symbol "--cl-var--"))) + (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) + (temp (make-symbol "--cl-var--")) + (minip (make-symbol "--cl-minip--"))) (push (list var (if scr (list 'frame-selected-window scr) '(selected-window))) loop-for-bindings) + ;; If we started in the minibuffer, we need to + ;; ensure that next-window will bring us back there + ;; at some point. (Bug#7492). + ;; (Consider using walk-windows instead of loop if + ;; you care about such things.) + (push (list minip `(minibufferp (window-buffer ,var))) + loop-for-bindings) (push (list temp nil) loop-for-bindings) (push (list 'prog1 (list 'not (list 'eq var temp)) (list 'or temp (list 'setq temp var))) loop-body) - (push (list var (list 'next-window var)) loop-for-steps))) + (push (list var (list 'next-window var minip)) + loop-for-steps))) (t (let ((handler (and (symbolp word) @@ -975,9 +990,9 @@ Valid clauses are: (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car args) 'and)) + (eq (car loop-args) 'and)) (setq ands t) - (pop args)) + (pop loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) loop-bindings) (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) @@ -993,11 +1008,11 @@ Valid clauses are: ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop args))) loop-bindings) + (push (list (list temp (pop loop-args))) loop-bindings) (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) ((memq word '(collect collecting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (if (eq var loop-accum-var) (push (list 'progn (list 'push what var) t) loop-body) @@ -1006,7 +1021,7 @@ Valid clauses are: t) loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (push (list 'progn (list 'setq var @@ -1021,27 +1036,27 @@ Valid clauses are: var what))) t) loop-body))) ((memq word '(concat concating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum ""))) (push (list 'progn (list 'callf 'concat var what) t) loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum []))) (push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) ((memq word '(sum summing)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'incf var what) t) loop-body))) ((memq word '(count counting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop args)) + (let* ((what (pop loop-args)) (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) (var (cl-loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) @@ -1052,27 +1067,27 @@ Valid clauses are: ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop args) - (and (eq (car args) '=) (cl-pop2 args))) + (while (progn (push (list (pop loop-args) + (and (eq (car loop-args) '=) (cl-pop2 loop-args))) bindings) - (eq (car args) 'and)) - (pop args)) + (eq (car loop-args) 'and)) + (pop loop-args)) (push (nreverse bindings) loop-bindings))) ((eq word 'while) - (push (pop args) loop-body)) + (push (pop loop-args) loop-body)) ((eq word 'until) - (push (list 'not (pop args)) loop-body)) + (push (list 'not (pop loop-args)) loop-body)) ((eq word 'always) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (pop args)) loop-body) + (push (list 'setq loop-finish-flag (pop loop-args)) loop-body) (setq loop-result t)) ((eq word 'never) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (list 'not (pop args))) + (push (list 'setq loop-finish-flag (list 'not (pop loop-args))) loop-body) (setq loop-result t)) @@ -1080,20 +1095,20 @@ Valid clauses are: (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) (push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (pop args)))) + (list 'not (list 'setq loop-result-var (pop loop-args)))) loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop args)) + (let* ((cond (pop loop-args)) (then (let ((loop-body nil)) (cl-parse-loop-clause) (cl-loop-build-ands (nreverse loop-body)))) (else (let ((loop-body nil)) - (if (eq (car args) 'else) - (progn (pop args) (cl-parse-loop-clause))) + (if (eq (car loop-args) 'else) + (progn (pop loop-args) (cl-parse-loop-clause))) (cl-loop-build-ands (nreverse loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (pop args)) + (if (eq (car loop-args) 'end) (pop loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) @@ -1107,22 +1122,22 @@ Valid clauses are: ((memq word '(do doing)) (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (push (pop args) body)) + (or (consp (car loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car loop-args)) (push (pop loop-args) body)) (push (cons 'progn (nreverse (cons t body))) loop-body))) ((eq word 'return) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-result-var (pop args) + (push (list 'setq loop-result-var (pop loop-args) loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) (or handler (error "Expected a loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car args) 'and) - (progn (pop args) (cl-parse-loop-clause))))) + (if (eq (car loop-args) 'and) + (progn (pop loop-args) (cl-parse-loop-clause))))) (defun cl-loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) @@ -1158,9 +1173,9 @@ Valid clauses are: (list* (if par 'let 'let*) (nconc (nreverse temps) (nreverse new)) body)))) -(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* - (if (eq (car args) 'into) - (let ((var (cl-pop2 args))) +(defun cl-loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car loop-args) 'into) + (let ((var (cl-pop2 loop-args))) (or (memq var loop-accum-vars) (progn (push (list (list var def)) loop-bindings) (push var loop-accum-vars))) @@ -1741,15 +1756,6 @@ Example: (defsetf default-file-modes set-default-file-modes t) (defsetf default-value set-default) (defsetf documentation-property put) -(defsetf extent-data set-extent-data) -(defsetf extent-face set-extent-face) -(defsetf extent-priority set-extent-priority) -(defsetf extent-end-position (ext) (store) - (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) - store) store)) -(defsetf extent-start-position (ext) (store) - (list 'progn (list 'set-extent-endpoints store - (list 'extent-end-position ext)) store)) (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) (defsetf face-background-pixmap (f &optional s) (x) (list 'set-face-background-pixmap f x s)) @@ -1763,6 +1769,7 @@ Example: (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-width set-screen-width t) (defsetf frame-parameter set-frame-parameter t) +(defsetf terminal-parameter set-terminal-parameter) (defsetf getenv setenv t) (defsetf get-register set-register) (defsetf global-key-binding global-set-key) @@ -1806,19 +1813,34 @@ Example: (defsetf window-height () (store) (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) (defsetf window-hscroll set-window-hscroll) +(defsetf window-parameter set-window-parameter) (defsetf window-point set-window-point) (defsetf window-start set-window-start) (defsetf window-width () (store) (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-cutbuffer x-store-cutbuffer t) -(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) (defsetf x-get-selection x-own-selection t) +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +(define-setf-method eq (place val) + (let ((method (get-setf-method place cl-macro-environment)) + (val-temp (make-symbol "--eq-val--")) + (store-temp (make-symbol "--eq-store--"))) + (list (append (nth 0 method) (list val-temp)) + (append (nth 1 method) (list val)) + (list store-temp) + `(let ((,(car (nth 2 method)) + (if ,store-temp ,val-temp (not ,val-temp)))) + ,(nth 3 method) ,store-temp) + `(eq ,(nth 4 method) ,val-temp)))) + ;;; More complex setf-methods. -;;; These should take &environment arguments, but since full arglists aren't -;;; available while compiling cl-macs, we fake it by referring to the global -;;; variable cl-macro-environment directly. +;; These should take &environment arguments, but since full arglists aren't +;; available while compiling cl-macs, we fake it by referring to the global +;; variable cl-macro-environment directly. (define-setf-method apply (func arg1 &rest rest) (or (and (memq (car-safe func) '(quote function function*)) @@ -2616,21 +2638,36 @@ surrounded by (block NAME ...). (cons '&cl-quote args)) (list* 'cl-defsubst-expand (list 'quote argns) (list 'quote (list* 'block name body)) - (not (or unsafe (cl-expr-access-order pbody argns))) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil (and (memq '&key args) 'cl-whole) unsafe argns))) (list* 'defun* name args body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole (if (cl-simple-exprs-p argvs) (setq simple t)) - (let ((lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) + (let* ((substs ()) + (lets (delq nil + (mapcar* (function + (lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv)))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (subst (cdar substs) (caar substs) body)) + (t (sublis substs body)))) (if lets (list 'let lets body) body)))) @@ -2753,5 +2790,4 @@ surrounded by (block NAME ...). ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index cb1730eff73..fcd21b73de7 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,11 +1,11 @@ ;;; cl-seq.el --- Common Lisp features, part 3 -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -47,6 +47,7 @@ ;;; this file independent from cl-macs. (defmacro cl-parsing-keywords (kwords other-keys &rest body) + (declare (indent 2) (debug (sexp sexp &rest form))) (cons 'let* (cons (mapcar @@ -83,13 +84,13 @@ (car cl-keys-temp))) '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) (defmacro cl-check-key (x) + (declare (debug edebug-forms)) (list 'if 'cl-key (list 'funcall 'cl-key x) x)) (defmacro cl-check-test-nokey (item x) + (declare (debug edebug-forms)) (list 'cond (list 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test item x)) @@ -100,20 +101,17 @@ (list 'equal item x) (list 'eq item x))))) (defmacro cl-check-test (item x) + (declare (debug edebug-forms)) (list 'cl-check-test-nokey item (list 'cl-check-key x))) (defmacro cl-check-match (x y) + (declare (debug edebug-forms)) (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) (list 'if 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) (list 'if (list 'numberp x) (list 'equal x y) (list 'eq x y)))) -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) - (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key) @@ -1019,5 +1017,4 @@ Atoms are compared by `eql'; cons cells are compared recursively. ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el index c21fbb1a17c..7359da65e07 100644 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@ -1,9 +1,9 @@ ;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*- -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Keywords: lisp, tools, maint +;; Package: emacs ;; LCD Archive Entry: ;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org @@ -468,5 +468,4 @@ (def-edebug-spec loop-d-type-spec (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) -;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478 ;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 54e6e9e70c2..1d2b82f82eb 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,7 +1,6 @@ ;;; cl.el --- Common Lisp extensions for Emacs -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -645,7 +644,6 @@ If ALIST is non-nil, the new pairs are prepended to it." (load "cl-loaddefs" nil 'quiet) ;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") (provide 'cl) ;; Things to do after byte-compiler is loaded. @@ -677,5 +675,4 @@ If ALIST is non-nil, the new pairs are prepended to it." ;; byte-compile-warnings: (not cl-functions) ;; End: -;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 1caa80be389..582785a0e90 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,7 +1,6 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1998, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 1998, 2001-2011 Free Software Foundation, Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> ;; Keywords: maint, tools @@ -47,6 +46,7 @@ This is useful for ChangeLogs." :group 'copyright :type 'boolean :version "23.1") +;;;###autoload(put 'copyright-at-end-flag 'safe-local-variable 'booleanp) (defcustom copyright-regexp "\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ @@ -66,6 +66,11 @@ someone else or to a group for which you do not work." :group 'copyright :type 'regexp) +;; The worst that can happen is a malicious regexp that overflows in +;; the regexp matcher, a minor nuisance. It's a pain to be always +;; prompted if you want to put this in a dir-locals.el. +;;;###autoload(put 'copyright-names-regexp 'safe-local-variable 'stringp) + (defcustom copyright-years-regexp "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "Match additional copyright notice years. @@ -73,6 +78,19 @@ The second \\( \\) construct must match the years." :group 'copyright :type 'regexp) +;; See "Copyright Notices" in maintain.info. +;; TODO? 'end only for ranges at the end, other for all ranges. +;; Minimum limit on the size of a range? +(defcustom copyright-year-ranges nil + "Non-nil if individual consecutive years should be replaced with a range. +For example: 2005, 2006, 2007, 2008 might be replaced with 2005-2008. +If you use ranges, you should add an explanatory note in a README file. +The function `copyright-fix-year' respects this variable." + :group 'copyright + :type 'boolean + :version "24.1") + +;;;###autoload(put 'copyright-year-ranges 'safe-local-variable 'booleanp) (defcustom copyright-query 'function "If non-nil, ask user before changing copyright. @@ -120,76 +138,88 @@ When this is `function', only ask when called non-interactively." (< (point) (- (point-max) copyright-limit)) (> (point) (+ (point-min) copyright-limit))))) +(defun copyright-find-copyright () + "Return non-nil if a copyright header suitable for updating is found. +The header must match `copyright-regexp' and `copyright-names-regexp', if set. +This function sets the match-data that `copyright-update-year' uses." + (widen) + (goto-char (copyright-start-point)) + (condition-case err + ;; (1) Need the extra \\( \\) around copyright-regexp because we + ;; goto (match-end 1) below. See note (2) below. + (copyright-re-search (concat "\\(" copyright-regexp + "\\)\\([ \t]*\n\\)?.*\\(?:" + copyright-names-regexp "\\)") + (copyright-limit) + t) + ;; In case the regexp is rejected. This is useful because + ;; copyright-update is typically called from before-save-hook where + ;; such an error is very inconvenient for the user. + (error (message "Can't update copyright: %s" err) nil))) + +(defun copyright-find-end () + "Possibly adjust the search performed by `copyright-find-copyright'. +If the years continue onto multiple lines that are marked as comments, +skips to the end of all the years." + (while (save-excursion + (and (eq (following-char) ?,) + (progn (forward-char 1) t) + (progn (skip-chars-forward " \t") (eolp)) + comment-start-skip + (save-match-data + (forward-line 1) + (and (looking-at comment-start-skip) + (goto-char (match-end 0)))) + (looking-at-p copyright-years-regexp))) + (forward-line 1) + (re-search-forward comment-start-skip) + ;; (2) Need the extra \\( \\) so that the years are subexp 3, as + ;; they are at note (1) above. + (re-search-forward (format "\\(%s\\)" copyright-years-regexp)))) + (defun copyright-update-year (replace noquery) - (when - (condition-case err - ;; (1) Need the extra \\( \\) around copyright-regexp because we - ;; goto (match-end 1) below. See note (2) below. - (copyright-re-search (concat "\\(" copyright-regexp - "\\)\\([ \t]*\n\\)?.*\\(?:" - copyright-names-regexp "\\)") - (copyright-limit) - t) - ;; In case the regexp is rejected. This is useful because - ;; copyright-update is typically called from before-save-hook where - ;; such an error is very inconvenient for the user. - (error (message "Can't update copyright: %s" err) nil)) - (goto-char (match-end 1)) - ;; If the years are continued onto multiple lines - ;; that are marked as comments, skip to the end of the years anyway. - (while (save-excursion - (and (eq (following-char) ?,) - (progn (forward-char 1) t) - (progn (skip-chars-forward " \t") (eolp)) - comment-start-skip - (save-match-data - (forward-line 1) - (and (looking-at comment-start-skip) - (goto-char (match-end 0)))) - (looking-at-p copyright-years-regexp))) - (forward-line 1) - (re-search-forward comment-start-skip) - ;; (2) Need the extra \\( \\) so that the years are subexp 3, as - ;; they are at note (1) above. - (re-search-forward (format "\\(%s\\)" copyright-years-regexp))) - - ;; Note that `current-time-string' isn't locale-sensitive. - (setq copyright-current-year (substring (current-time-string) -4)) - (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) - (substring copyright-current-year -2)) - (if (or noquery + ;; This uses the match-data from copyright-find-copyright/end. + (goto-char (match-end 1)) + (copyright-find-end) + ;; Note that `current-time-string' isn't locale-sensitive. + (setq copyright-current-year (substring (current-time-string) -4)) + (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) + (substring copyright-current-year -2)) + (if (or noquery + (save-window-excursion + (switch-to-buffer (current-buffer)) ;; Fixes some point-moving oddness (bug#2209). (save-excursion (y-or-n-p (if replace (concat "Replace copyright year(s) by " copyright-current-year "? ") (concat "Add " copyright-current-year - " to copyright? "))))) - (if replace - (replace-match copyright-current-year t t nil 3) - (let ((size (save-excursion (skip-chars-backward "0-9")))) - (if (and (eq (% (- (string-to-number copyright-current-year) - (string-to-number (buffer-substring - (+ (point) size) - (point)))) - 100) - 1) - (or (eq (char-after (+ (point) size -1)) ?-) - (eq (char-after (+ (point) size -2)) ?-))) - ;; This is a range so just replace the end part. - (delete-char size) - ;; Insert a comma with the preferred number of spaces. - (insert - (save-excursion - (if (re-search-backward "[0-9]\\( *, *\\)[0-9]" - (line-beginning-position) t) - (match-string 1) - ", "))) - ;; If people use the '91 '92 '93 scheme, do that as well. - (if (eq (char-after (+ (point) size -3)) ?') - (insert ?'))) - ;; Finally insert the new year. - (insert (substring copyright-current-year size)))))))) + " to copyright? ")))))) + (if replace + (replace-match copyright-current-year t t nil 3) + (let ((size (save-excursion (skip-chars-backward "0-9")))) + (if (and (eq (% (- (string-to-number copyright-current-year) + (string-to-number (buffer-substring + (+ (point) size) + (point)))) + 100) + 1) + (or (eq (char-after (+ (point) size -1)) ?-) + (eq (char-after (+ (point) size -2)) ?-))) + ;; This is a range so just replace the end part. + (delete-char size) + ;; Insert a comma with the preferred number of spaces. + (insert + (save-excursion + (if (re-search-backward "[0-9]\\( *, *\\)[0-9]" + (line-beginning-position) t) + (match-string 1) + ", "))) + ;; If people use the '91 '92 '93 scheme, do that as well. + (if (eq (char-after (+ (point) size -3)) ?') + (insert ?'))) + ;; Finally insert the new year. + (insert (substring copyright-current-year size))))))) ;;;###autoload (defun copyright-update (&optional arg interactivep) @@ -206,74 +236,110 @@ interactively." (and (eq copyright-query 'function) interactivep)))) (save-excursion (save-restriction - (widen) - (goto-char (copyright-start-point)) - (copyright-update-year arg noquery) - (goto-char (copyright-start-point)) - (and copyright-current-gpl-version - ;; match the GPL version comment in .el files, including the - ;; bilingual Esperanto one in two-column, and in texinfo.tex - (copyright-re-search - "\\(the Free Software Foundation;\ - either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)\ -version \\([0-9]+\\), or (at" - (copyright-limit) t) - ;; Don't update if the file is already using a more recent - ;; version than the "current" one. - (< (string-to-number (match-string 3)) - (string-to-number copyright-current-gpl-version)) - (or noquery - (save-match-data - (y-or-n-p (format "Replace GPL version by %s? " - copyright-current-gpl-version)))) - (progn - (if (match-end 2) - ;; Esperanto bilingual comment in two-column.el - (replace-match copyright-current-gpl-version t t nil 2)) - (replace-match copyright-current-gpl-version t t nil 3)))) + ;; If names-regexp doesn't match, we should not mess with + ;; the years _or_ the GPL version. + ;; TODO there may be multiple copyrights we should update. + (when (copyright-find-copyright) + (copyright-update-year arg noquery) + (goto-char (copyright-start-point)) + (and copyright-current-gpl-version + ;; Match the GPL version comment in .el files. + ;; This is sensitive to line-breaks. :( + (copyright-re-search + "the Free Software Foundation[,;\n].*either version \ +\\([0-9]+\\)\\(?: of the License\\)?, or[ \n].*any later version" + (copyright-limit) t) + ;; Don't update if the file is already using a more recent + ;; version than the "current" one. + (< (string-to-number (match-string 1)) + (string-to-number copyright-current-gpl-version)) + (or noquery + (save-match-data + (goto-char (match-end 1)) + (save-window-excursion + (switch-to-buffer (current-buffer)) + (y-or-n-p + (format "Replace GPL version %s with version %s? " + (match-string-no-properties 1) + copyright-current-gpl-version))))) + (replace-match copyright-current-gpl-version t t nil 1)))) (set (make-local-variable 'copyright-update) nil))) ;; If a write-file-hook returns non-nil, the file is presumed to be written. nil)) -;; FIXME should be within 50 years of present (cf calendar). +;; FIXME heuristic should be within 50 years of present (cf calendar). ;;;###autoload (defun copyright-fix-years () "Convert 2 digit years to 4 digit years. -Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." +Uses heuristic: year >= 50 means 19xx, < 50 means 20xx. +If `copyright-year-ranges' (which see) is non-nil, also +independently replaces consecutive years with a range." (interactive) - (widen) - (goto-char (copyright-start-point)) - (if (copyright-re-search copyright-regexp (copyright-limit) t) - (let ((s (match-beginning 2)) - (e (copy-marker (1+ (match-end 2)))) + ;; TODO there may be multiple copyrights we should fix. + (if (copyright-find-copyright) + (let ((s (match-beginning 3)) (p (make-marker)) - last) + ;; Not line-beg-pos, so we don't mess up leading whitespace. + (copystart (match-beginning 0)) + e last sep year prev-year first-year range-start range-end) + ;; In case years are continued over multiple, commented lines. + (goto-char (match-end 1)) + (copyright-find-end) + (setq e (copy-marker (1+ (match-end 3)))) (goto-char s) (while (re-search-forward "[0-9]+" e t) (set-marker p (point)) (goto-char (match-beginning 0)) - (let ((sep (char-before)) - (year (string-to-number (match-string 0)))) - (when (and sep - (/= (char-syntax sep) ?\s) - (/= sep ?-)) - (insert " ")) - (when (< year 100) - (insert (if (>= year 50) "19" "20")))) + (setq year (string-to-number (match-string 0))) + (and (setq sep (char-before)) + (/= (char-syntax sep) ?\s) + (/= sep ?-) + (insert " ")) + (when (< year 100) + (insert (if (>= year 50) "19" "20")) + (setq year (+ year (if (>= year 50) 1900 2000)))) (goto-char p) - (setq last p)) + (when copyright-year-ranges + ;; If the previous thing was a range, don't try to tack more on. + ;; Ie not 2000-2005 -> 2000-2005-2007 + ;; TODO should merge into existing range if possible. + (if (eq sep ?-) + (setq prev-year nil + year nil) + (if (and prev-year (= year (1+ prev-year))) + (setq range-end (point)) + (when (and first-year prev-year + (> prev-year first-year)) + (goto-char range-end) + (delete-region range-start range-end) + (insert (format "-%d" prev-year)) + (goto-char p)) + (setq first-year year + range-start (point))))) + (setq prev-year year + last p)) (when last + (when (and copyright-year-ranges + first-year prev-year + (> prev-year first-year)) + (goto-char range-end) + (delete-region range-start range-end) + (insert (format "-%d" prev-year))) (goto-char last) ;; Don't mess up whitespace after the years. (skip-chars-backward " \t") - (save-restriction - (narrow-to-region (copyright-start-point) (point)) - (let ((fill-prefix " ")) - (fill-region s last)))) + (save-restriction + (narrow-to-region copystart (point)) + ;; This is clearly wrong, eg what about comment markers? + ;;; (let ((fill-prefix " ")) + ;; TODO do not break copyright owner over lines. + (fill-region (point-min) (point-max)))) (set-marker e nil) - (set-marker p nil) - (copyright-update nil t)) + (set-marker p nil)) + ;; Simply reformatting the years is not copyrightable, so it does + ;; not seem right to call this. Also it messes with ranges. +;;; (copyright-update nil t)) (message "No copyright message"))) ;;;###autoload @@ -288,17 +354,24 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." (message "Copyright extends beyond `copyright-limit' and won't be updated automatically.")) comment-end \n) +;; TODO: recurse, exclude COPYING etc. ;;;###autoload -(defun copyright-update-directory (directory match) - "Update copyright notice for all files in DIRECTORY matching MATCH." +(defun copyright-update-directory (directory match &optional fix) + "Update copyright notice for all files in DIRECTORY matching MATCH. +If FIX is non-nil, run `copyright-fix-years' instead." (interactive "DDirectory: \nMFilenames matching (regexp): ") (dolist (file (directory-files directory t match nil)) - (message "Updating file `%s'" file) - (find-file file) - (let ((copyright-query nil)) - (copyright-update)) - (save-buffer) - (kill-buffer (current-buffer)))) + (unless (file-directory-p file) + (message "Updating file `%s'" file) + (find-file file) + (let ((inhibit-read-only t) + (enable-local-variables :safe) + copyright-query) + (if fix + (copyright-fix-years) + (copyright-update))) + (save-buffer) + (kill-buffer (current-buffer))))) (provide 'copyright) @@ -307,5 +380,4 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." ;; coding: utf-8 ;; End: -;; arch-tag: b4991afb-b6b1-4590-bebe-e076d9d4aee8 ;;; copyright.el ends here diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 8c7d48d7e0c..3848ab7e6ea 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,7 +1,6 @@ ;;; crm.el --- read multiple strings with completion -;; Copyright (C) 1985, 1986, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1993-2011 Free Software Foundation, Inc. ;; Author: Sen Nagata <sen@eccosys.com> ;; Keywords: completion, minibuffer, multiple elements @@ -321,5 +320,4 @@ INHERIT-INPUT-METHOD." (provide 'crm) -;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6 ;;; crm.el ends here diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el index 5b8ce9909bd..e7f9aae1c60 100644 --- a/lisp/emacs-lisp/cust-print.el +++ b/lisp/emacs-lisp/cust-print.el @@ -1,7 +1,6 @@ ;;; cust-print.el --- handles print-level and print-circle -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Adapted-By: ESR @@ -681,5 +680,4 @@ See `custom-format' for the details." (provide 'cust-print) -;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580 ;;; cust-print.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index a752d4bfaf0..88633eaaa46 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,7 +1,6 @@ ;;; debug.el --- debuggers and related commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2001-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, tools, maint @@ -514,9 +513,9 @@ Applies to the frame whose line point is on in the backtrace." (insert ? ))) (beginning-of-line)) -(put 'debugger-env-macro 'lisp-indent-function 0) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." + (declare (indent 0)) `(save-excursion (if (null (buffer-name debugger-old-buffer)) ;; old buffer deleted @@ -890,5 +889,4 @@ To specify a nil argument interactively, exit with an empty minibuffer." (provide 'debug) -;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b ;;; debug.el ends here diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 36298e47a72..425a77ee77f 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,12 +1,12 @@ ;;; derived.el --- allow inheritance of major modes ;; (formerly mode-clone.el) -;; Copyright (C) 1993, 1994, 1999, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 1999, 2001-2011 Free Software Foundation, Inc. ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) ;; Maintainer: FSF ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -230,7 +230,7 @@ No problems result if this variable is not bound. ; Run the parent. (delay-mode-hooks - (,(or parent 'kill-all-local-variables)) + (,(or parent 'fundamental-mode)) ; Identify the child mode. (setq major-mode (quote ,child)) (setq mode-name ,name) @@ -456,5 +456,4 @@ Where the new table already has an entry, nothing is copied from the old one." (provide 'derived) -;; arch-tag: 630be248-47d1-4f02-afa0-8207de0ebea0 ;;; derived.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index ae69f13143e..9f4cca91676 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -1,7 +1,6 @@ ;;; disass.el --- disassembler for compiled Emacs Lisp code -;; Copyright (C) 1986, 1991, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1986, 1991, 2002-2011 Free Software Foundation, Inc. ;; Author: Doug Cutting <doug@csli.stanford.edu> ;; Jamie Zawinski <jwz@lucid.com> @@ -264,5 +263,4 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (provide 'disass) -;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a ;;; disass.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 3876e291d1b..46dc1f162ba 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,10 +1,10 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2000-2011 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> +;; Package: emacs ;; Keywords: extensions lisp @@ -115,6 +115,12 @@ BODY contains code to execute each time the mode is enabled or disabled. :lighter SPEC Same as the LIGHTER argument. :keymap MAP Same as the KEYMAP argument. :require SYM Same as in `defcustom'. +:variable PLACE The location (as can be used with `setf') to use instead + of the variable MODE to store the state of the mode. PLACE + can also be of the form (GET . SET) where GET is an expression + that returns the current state and SET is a function that takes + a new state and sets it. If you specify a :variable, this + function assumes it is defined elsewhere. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" @@ -146,6 +152,9 @@ For example, you could write (type nil) (extra-args nil) (extra-keywords nil) + (variable nil) ;The PLACE where the state is stored. + (setter nil) ;The function (if any) to set the mode var. + (modefun mode) ;The minor mode function name we're defining. (require t) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) @@ -166,6 +175,12 @@ For example, you could write (:type (setq type (list :type (pop body)))) (:require (setq require (pop body))) (:keymap (setq keymap (pop body))) + (:variable (setq variable (pop body)) + (if (not (functionp (cdr-safe variable))) + ;; PLACE is not of the form (GET . SET). + (setq mode variable) + (setq mode (car variable)) + (setq setter (cdr variable)))) (t (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap @@ -182,16 +197,21 @@ For example, you could write `(:group ',(intern (replace-regexp-in-string "-mode\\'" "" mode-name))))) + ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode. (unless type (setq type '(:type 'boolean))) `(progn ;; Define the variable to enable or disable the mode. - ,(if (not globalp) - `(progn - (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. + ,(cond + ;; If :variable is specified, then the var will be + ;; declared elsewhere. + (variable nil) + ((not globalp) + `(progn + (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. Use the command `%s' to change this variable." pretty-name mode)) - (make-variable-buffer-local ',mode)) - + (make-variable-buffer-local ',mode))) + (t (let ((base-doc-string (concat "Non-nil if %s is enabled. See the command `%s' for a description of this minor mode." @@ -206,10 +226,10 @@ or call the function `%s'.")))) ,@group ,@type ,@(unless (eq require t) `(:require ,require)) - ,@(nreverse extra-keywords)))) + ,@(nreverse extra-keywords))))) ;; The actual function. - (defun ,mode (&optional arg ,@extra-args) + (defun ,modefun (&optional arg ,@extra-args) ,(or doc (format (concat "Toggle %s on or off. Interactively, with no prefix argument, toggle the mode. @@ -220,22 +240,19 @@ With zero or negative ARG turn mode off. ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) (let ((,last-message (current-message))) - (setq ,mode - (cond - ((eq arg 'toggle) (not ,mode)) - (arg (> (prefix-numeric-value arg) 0)) - (t - (if (null ,mode) t - (message - "Toggling %s off; better pass an explicit argument." - ',mode) - nil)))) + (,@(if setter (list setter) + (list (if (symbolp mode) 'setq 'setf) mode)) + (if (eq arg 'toggle) + (not ,mode) + ;; A nil argument also means ON now. + (> (prefix-numeric-value arg) 0))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) (if (called-interactively-p 'any) (progn - ,(if globalp `(customize-mark-as-set ',mode)) + ,(if (and globalp (symbolp mode)) + `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) @@ -260,9 +277,15 @@ With zero or negative ARG turn mode off. (t (error "Invalid keymap %S" m)))) ,(format "Keymap for `%s'." mode-name))) - (add-minor-mode ',mode ',lighter - ,(if keymap keymap-sym - `(if (boundp ',keymap-sym) ,keymap-sym)))))) + ,(if (not (symbolp mode)) + (if (or lighter keymap) + (error ":lighter and :keymap unsupported with mode expression %s" mode)) + `(with-no-warnings + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) ,keymap-sym)) + nil + ,(unless (eq mode modefun) 'modefun))))))) ;;; ;;; make global minor mode @@ -342,9 +365,11 @@ See `%s' for more information on %s." (progn (add-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (add-hook 'fundamental-mode-hook ',MODE-enable-in-buffers) (add-hook 'find-file-hook ',MODE-check-buffers) (add-hook 'change-major-mode-hook ',MODE-cmhh)) (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (remove-hook 'fundamental-mode-hook ',MODE-enable-in-buffers) (remove-hook 'find-file-hook ',MODE-check-buffers) (remove-hook 'change-major-mode-hook ',MODE-cmhh)) @@ -365,13 +390,14 @@ See `%s' for more information on %s." (dolist (buf ,MODE-buffers) (when (buffer-live-p buf) (with-current-buffer buf - (if ,mode - (unless (eq ,MODE-major-mode major-mode) - (,mode -1) - (,turn-on) - (setq ,MODE-major-mode major-mode)) - (,turn-on) - (setq ,MODE-major-mode major-mode)))))) + (unless (eq ,MODE-major-mode major-mode) + (if ,mode + (progn + (,mode -1) + (,turn-on) + (setq ,MODE-major-mode major-mode)) + (,turn-on) + (setq ,MODE-major-mode major-mode))))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) (defun ,MODE-check-buffers () @@ -559,5 +585,4 @@ BODY is executed after moving to the destination location." (provide 'easy-mmode) -;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 2ddbad7d92d..79573437146 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,10 +1,10 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu -;; Copyright (C) 1994, 1996, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998-2011 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> +;; Package: emacs ;; This file is part of GNU Emacs. @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (defvar easy-menu-precalculate-equivalent-keybindings nil "Determine when equivalent key bindings are computed for easy-menu menus. It can take some time to calculate the equivalent key bindings that are shown @@ -43,8 +45,6 @@ menus, turn this variable off, otherwise it is probably better to keep it on.") (if (stringp s) (intern s) s)) ;;;###autoload -(put 'easy-menu-define 'lisp-indent-function 'defun) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a menu bar submenu in maps MAPS, according to MENU. @@ -67,8 +67,8 @@ expression has a non-nil value. `:included' is an alias for `:visible'. :active ENABLE -ENABLE is an expression; the menu is enabled for selection -whenever this expression's value is non-nil. +ENABLE is an expression; the menu is enabled for selection whenever +this expression's value is non-nil. `:enable' is an alias for `:active'. The rest of the elements in MENU, are menu items. @@ -105,8 +105,8 @@ keyboard equivalent. :active ENABLE -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. +ENABLE is an expression; the item is enabled for selection whenever +this expression's value is non-nil. `:enable' is an alias for `:active'. :visible INCLUDE @@ -150,6 +150,7 @@ unselectable text. A string consisting solely of hyphens is displayed as a solid horizontal line. A menu item can be a list with the same format as MENU. This is a submenu." + (declare (indent defun)) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) @@ -163,10 +164,13 @@ This is expected to be bound to a mouse event." (prog1 (get menu 'menu-prop) (setq menu (symbol-function menu)))))) (cons 'menu-item - (cons (or item-name - (if (keymapp menu) - (keymap-prompt menu)) - "") + (cons (if (eq :label (car props)) + (prog1 (cadr props) + (setq props (cddr props))) + (or item-name + (if (keymapp menu) + (keymap-prompt menu)) + "")) (cons menu props))))) ;;;###autoload @@ -232,15 +236,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (keywordp (setq keyword (car menu-items)))) (setq arg (cadr menu-items)) (setq menu-items (cddr menu-items)) - (cond - ((eq keyword :filter) + (case keyword + (:filter (setq filter `(lambda (menu) (easy-menu-filter-return (,arg menu) ,menu-name)))) - ((eq keyword :active) (setq enable (or arg ''nil))) - ((eq keyword :label) (setq label arg)) - ((eq keyword :help) (setq help arg)) - ((or (eq keyword :included) (eq keyword :visible)) - (setq visible (or arg ''nil))))) + ((:enable :active) (setq enable (or arg ''nil))) + (:label (setq label arg)) + (:help (setq help arg)) + ((:included :visible) (setq visible (or arg ''nil))))) (if (equal visible ''nil) nil ; Invisible menu entry, return nil. (if (and visible (not (easy-menu-always-true-p visible))) @@ -249,14 +252,14 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (setq prop (cons :enable (cons enable prop)))) (if filter (setq prop (cons :filter (cons filter prop)))) (if help (setq prop (cons :help (cons help prop)))) - (if label (setq prop (cons nil (cons label prop)))) - (if filter - ;; The filter expects the menu in its XEmacs form and the pre-filter - ;; form will only be passed to the filter anyway, so we'd better - ;; not convert it at all (it will be converted on the fly by - ;; easy-menu-filter-return). - (setq menu menu-items) - (setq menu (append menu (mapcar 'easy-menu-convert-item menu-items)))) + (if label (setq prop (cons :label (cons label prop)))) + (setq menu (if filter + ;; The filter expects the menu in its XEmacs form and the + ;; pre-filter form will only be passed to the filter + ;; anyway, so we'd better not convert it at all (it will + ;; be converted on the fly by easy-menu-filter-return). + menu-items + (append menu (mapcar 'easy-menu-convert-item menu-items)))) (when prop (setq menu (easy-menu-make-symbol menu 'noexp)) (put menu 'menu-prop prop)) @@ -312,7 +315,7 @@ ITEM defines an item as in `easy-menu-define'." ;; Invisible menu item. Don't insert into keymap. (setq remove t) (when (and (symbolp command) (setq prop (get command 'menu-prop))) - (when (null (car prop)) + (when (eq :label (car prop)) (setq label (cadr prop)) (setq prop (cddr prop))) (setq command (symbol-function command))))) @@ -331,30 +334,28 @@ ITEM defines an item as in `easy-menu-define'." (setq keyword (aref item count)) (setq arg (aref item (1+ count))) (setq count (+ 2 count)) - (cond - ((or (eq keyword :included) (eq keyword :visible)) - (setq visible (or arg ''nil))) - ((eq keyword :key-sequence) - (setq cache arg cache-specified t)) - ((eq keyword :keys) (setq keys arg no-name nil)) - ((eq keyword :label) (setq label arg)) - ((eq keyword :active) (setq active (or arg ''nil))) - ((eq keyword :help) (setq prop (cons :help (cons arg prop)))) - ((eq keyword :suffix) (setq suffix arg)) - ((eq keyword :style) (setq style arg)) - ((eq keyword :selected) (setq selected (or arg ''nil))))) + (case keyword + ((:included :visible) (setq visible (or arg ''nil))) + (:key-sequence (setq cache arg cache-specified t)) + (:keys (setq keys arg no-name nil)) + (:label (setq label arg)) + ((:active :enable) (setq active (or arg ''nil))) + (:help (setq prop (cons :help (cons arg prop)))) + (:suffix (setq suffix arg)) + (:style (setq style arg)) + (:selected (setq selected (or arg ''nil))))) (if suffix (setq label (if (stringp suffix) (if (stringp label) (concat label " " suffix) - (list 'concat label (concat " " suffix))) + `(concat ,label ,(concat " " suffix))) (if (stringp label) - (list 'concat (concat label " ") suffix) - (list 'concat label " " suffix))))) + `(concat ,(concat label " ") ,suffix) + `(concat ,label " " ,suffix))))) (cond ((eq style 'button) (setq label (if (stringp label) (concat "[" label "]") - (list 'concat "[" label "]")))) + `(concat "[" ,label "]")))) ((and selected (setq style (assq style easy-menu-button-prefix))) (setq prop (cons :button @@ -674,5 +675,4 @@ In some cases we use that to select between the local and global maps." (provide 'easymenu) -;; arch-tag: 2a04020d-90d2-476d-a7c6-71e072007a4a ;;; easymenu.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index cfd80b80927..f281521841c 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,8 +1,6 @@ ;;; edebug.el --- a source-level debugger for Emacs Lisp -;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 1988-1995, 1997, 1999-2011 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Maintainer: FSF @@ -885,17 +883,12 @@ already is one.)" (edebug-storing-offsets (1- (point)) 'quote) (edebug-read-storing-offsets stream))) -(defvar edebug-read-backquote-level 0 - "If non-zero, we're in a new-style backquote. -It should never be negative. This controls how we read comma constructs.") - (defun edebug-read-backquote (stream) ;; Turn `thing into (\` thing) (forward-char 1) (list (edebug-storing-offsets (1- (point)) '\`) - (let ((edebug-read-backquote-level (1+ edebug-read-backquote-level))) - (edebug-read-storing-offsets stream)))) + (edebug-read-storing-offsets stream))) (defun edebug-read-comma (stream) ;; Turn ,thing into (\, thing). Handle ,@ and ,. also. @@ -910,12 +903,9 @@ It should never be negative. This controls how we read comma constructs.") (forward-char 1))) ;; Generate the same structure of offsets we would have ;; if the resulting list appeared verbatim in the input text. - (if (zerop edebug-read-backquote-level) - (edebug-storing-offsets opoint symbol) - (list - (edebug-storing-offsets opoint symbol) - (let ((edebug-read-backquote-level (1- edebug-read-backquote-level))) - (edebug-read-storing-offsets stream))))))) + (list + (edebug-storing-offsets opoint symbol) + (edebug-read-storing-offsets stream))))) (defun edebug-read-function (stream) ;; Turn #'thing into (function thing) @@ -937,17 +927,7 @@ It should never be negative. This controls how we read comma constructs.") (prog1 (let ((elements)) (while (not (memq (edebug-next-token-class) '(rparen dot))) - (if (and (eq (edebug-next-token-class) 'backquote) - (null elements) - (zerop edebug-read-backquote-level)) - (progn - ;; Old style backquote. - (forward-char 1) ; Skip backquote. - ;; Call edebug-storing-offsets here so that we - ;; produce the same offsets we would have had - ;; if the backquote were an ordinary symbol. - (push (edebug-storing-offsets (1- (point)) '\`) elements)) - (push (edebug-read-storing-offsets stream) elements))) + (push (edebug-read-storing-offsets stream) elements)) (setq elements (nreverse elements)) (if (eq 'dot (edebug-next-token-class)) (let (dotted-form) @@ -2149,8 +2129,6 @@ expressions; a `progn' form will be returned enclosing these forms." (def-edebug-spec with-custom-print body) -(def-edebug-spec sregexq (&rest sexp)) -(def-edebug-spec rx (&rest sexp)) ;;; The debugger itself @@ -3009,7 +2987,7 @@ MSG is printed after `::::} '." ;; Set up the overlay arrow at beginning-of-line in current buffer. ;; The arrow string is derived from edebug-arrow-alist and ;; edebug-execution-mode. - (let ((pos (save-excursion (beginning-of-line) (point)))) + (let ((pos (line-beginning-position))) (setq overlay-arrow-string (cdr (assq edebug-execution-mode edebug-arrow-alist))) (setq overlay-arrow-position (make-marker)) @@ -4029,18 +4007,16 @@ May only be called from within `edebug-recursive-edit'." -(defvar edebug-eval-mode-map nil - "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") - -(unless edebug-eval-mode-map - (setq edebug-eval-mode-map (make-sparse-keymap)) - (set-keymap-parent edebug-eval-mode-map lisp-interaction-mode-map) - - (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) - (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) - (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) - (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp)) +(defvar edebug-eval-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-interaction-mode-map) + (define-key map "\C-c\C-w" 'edebug-where) + (define-key map "\C-c\C-d" 'edebug-delete-eval-item) + (define-key map "\C-c\C-u" 'edebug-update-eval-list) + (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) + (define-key map "\C-j" 'edebug-eval-print-last-sexp) + map) +"Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") (put 'edebug-eval-mode 'mode-class 'special) @@ -4455,7 +4431,7 @@ With prefix argument, make it a temporary breakpoint." (add-hook 'cl-load-hook (function (lambda () (require 'cl-specs))))) -;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu +;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu (if (featurep 'cl-read) (add-hook 'edebug-setup-hook (function (lambda () (require 'edebug-cl-read)))) @@ -4466,13 +4442,12 @@ With prefix argument, make it a temporary breakpoint." ;;; Finalize Loading -;;; Finally, hook edebug into the rest of Emacs. -;;; There are probably some other things that could go here. +;; Finally, hook edebug into the rest of Emacs. +;; There are probably some other things that could go here. ;; Install edebug read and eval functions. (edebug-install-read-eval-functions) (provide 'edebug) -;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808 ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 3676910faad..139f5e6a4ce 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,11 +1,12 @@ ;;; eieio-base.el --- Base classes for EIEIO. -;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010, 2011 +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2011 ;;; Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -328,5 +329,4 @@ a set type." (provide 'eieio-base) -;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b ;;; eieio-base.el ends here diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el index 70981a1b347..ed6fb6f1c41 100644 --- a/lisp/emacs-lisp/eieio-comp.el +++ b/lisp/emacs-lisp/eieio-comp.el @@ -1,11 +1,12 @@ ;;; eieio-comp.el -- eieio routines to help with byte compilation -;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011 +;; Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 -;; Keywords: oop, lisp, tools +;; Keywords: lisp, tools +;; Package: eieio ;; This file is part of GNU Emacs. @@ -46,10 +47,6 @@ ;; This teaches the byte compiler how to do this sort of thing. (put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) -;; Variables used free: -(defvar outbuffer) -(defvar filename) - (defun byte-compile-file-form-defmethod (form) "Mumble about the method we are compiling. This function is mostly ripped from `byte-compile-file-form-defun', @@ -82,14 +79,18 @@ that is called but rarely. Argument FORM is the body of the method." (class (if (listp arg1) (nth 1 arg1) nil)) (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) byte-compile-outbuffer - (condition-case nil - bytecomp-outbuffer - (error outbuffer)))) - ) + (cond ((boundp 'bytecomp-outbuffer) + bytecomp-outbuffer) ; Emacs >= 23.2 + ((boundp 'outbuffer) outbuffer) + (t (error "Unable to set outbuffer")))))) (let ((name (format "%s::%s" (or class "#<generic>") meth))) (if byte-compile-verbose ;; #### filename used free - (message "Compiling %s... (%s)" (or filename "") name)) + (message "Compiling %s... (%s)" + (cond ((boundp 'bytecomp-filename) bytecomp-filename) + ((boundp 'filename) filename) + (t "")) + name)) (setq byte-compile-current-form name) ; for warnings ) ;; Flush any pending output @@ -138,5 +139,4 @@ Argument PARAMLIST is the parameter list to convert." (provide 'eieio-comp) -;; arch-tag: f2aacdd3-1da2-4ee9-b3e5-e8eac0832ee3 ;;; eieio-comp.el ends here diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index e547fa77fe3..6fe63fcb754 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,11 +1,11 @@ ;;; eieio-custom.el -- eieio object customization -;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 1999-2001, 2005, 2007-2011 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -460,5 +460,4 @@ Return the symbol for the group, or nil" (provide 'eieio-custom) -;; arch-tag: bc122762-a771-48d5-891b-7835b16dd924 ;;; eieio-custom.el ends here diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 06c47f47e41..60510e1816c 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -1,9 +1,10 @@ ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2007-2011 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -144,5 +145,4 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (provide 'eieio-datadebug) -;; arch-tag: 6c7c2890-7614-41b0-816b-c61f3f6a8130 ;;; eieio-datadebug.el ends here diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 245a2dbfff5..ddc6616ba28 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,11 +1,12 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2011 +;; Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. @@ -692,5 +693,4 @@ INDENT is the current indentation level." (provide 'eieio-opt) -;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6 ;;; eieio-opt.el ends here diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index 73f15fd5d88..d28ecd9615b 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,11 +1,11 @@ ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 1999-2002, 2005, 2007-2011 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, tools +;; Package: eieio ;; This file is part of GNU Emacs. @@ -421,5 +421,4 @@ to create a speedbar button." (provide 'eieio-speedbar) -;; arch-tag: eaac1283-10b0-4419-a929-982b87e83234 ;;; eieio-speedbar.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 4adec99f61b..d958bfbd45c 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1,8 +1,7 @@ ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects ;;; or maybe Eric's Implementation of Emacs Intrepreted Objects -;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 1998-2011 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 1.3 @@ -1629,6 +1628,7 @@ SPEC-LIST is of a form similar to `let'. For example: Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." + (declare (indent 2)) ;; Transform the spec-list into a symbol-macrolet spec-list. (let ((mappings (mapcar (lambda (entry) (let ((var (if (listp entry) (car entry) entry)) @@ -1637,8 +1637,6 @@ variable name of the same name as the slot." spec-list))) (append (list 'symbol-macrolet mappings) body))) -(put 'with-slots 'lisp-indent-function 2) - ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -2957,5 +2955,4 @@ Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." (provide 'eieio) -;; arch-tag: c1aeab9c-2938-41a3-842b-1a38bd26e9f2 ;;; eieio ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index b9dc69ec819..cd9b779bee9 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -1,7 +1,6 @@ ;;; eldoc.el --- show function arglist or variable docstring in echo area -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-2011 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Maintainer: friedman@splode.com @@ -530,15 +529,14 @@ The words \"&rest\", \"&optional\" are returned unchanged." ;; Prime the command list. (eldoc-add-command-completions - "backward-" "beginning-of-" "move-beginning-of-" "delete-other-windows" - "delete-window" "handle-select-window" - "end-of-" "move-end-of-" "exchange-point-and-mark" "forward-" - "indent-for-tab-command" "goto-" "mark-page" "mark-paragraph" - "mouse-set-point" "move-" "pop-global-mark" "next-" "other-window" - "previous-" "recenter" "scroll-" "self-insert-command" - "split-window-" "up-list" "down-list") + "backward-" "beginning-of-" "delete-other-windows" "delete-window" + "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" + "handle-select-window" "indent-for-tab-command" "left-" "mark-page" + "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" + "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-" + "recenter" "right-" "scroll-" "self-insert-command" "split-window-" + "up-list") (provide 'eldoc) -;; arch-tag: c9a58f9d-2055-46c1-9b82-7248b71a8375 ;;; eldoc.el ends here diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 1583e101d11..36c26676fe9 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,7 +1,6 @@ ;;; elint.el --- Lint Emacs Lisp -;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001-2011 Free Software Foundation, Inc. ;; Author: Peter Liljenberg <petli@lysator.liu.se> ;; Created: May 1997 @@ -394,40 +393,41 @@ Return nil if there are no more forms, t otherwise." (parse-partial-sexp (point) (point-max) nil t) (not (eobp))) -(defvar env) ; from elint-init-env +(defvar elint-env) ; from elint-init-env (defun elint-init-form (form) - "Process FORM, adding to ENV if recognized." + "Process FORM, adding to ELINT-ENV if recognized." (cond ;; Eg nnmaildir seems to use [] as a form of comment syntax. ((not (listp form)) (elint-warning "Skipping non-list form `%s'" form)) ;; Add defined variable ((memq (car form) '(defvar defconst defcustom)) - (setq env (elint-env-add-var env (cadr form)))) + (setq elint-env (elint-env-add-var elint-env (cadr form)))) ;; Add function ((memq (car form) '(defun defsubst)) - (setq env (elint-env-add-func env (cadr form) (nth 2 form)))) + (setq elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form)))) ;; FIXME needs a handler to say second arg is not a variable when we come ;; to scan the form. ((eq (car form) 'define-derived-mode) - (setq env (elint-env-add-func env (cadr form) ()) - env (elint-env-add-var env (cadr form)) - env (elint-env-add-var env (intern (format "%s-map" (cadr form)))))) + (setq elint-env (elint-env-add-func elint-env (cadr form) ()) + elint-env (elint-env-add-var elint-env (cadr form)) + elint-env (elint-env-add-var elint-env + (intern (format "%s-map" (cadr form)))))) ((eq (car form) 'define-minor-mode) - (setq env (elint-env-add-func env (cadr form) '(&optional arg)) + (setq elint-env (elint-env-add-func elint-env (cadr form) '(&optional arg)) ;; FIXME mode map? - env (elint-env-add-var env (cadr form)))) + elint-env (elint-env-add-var elint-env (cadr form)))) ((and (eq (car form) 'easy-menu-define) (cadr form)) - (setq env (elint-env-add-func env (cadr form) '(event)) - env (elint-env-add-var env (cadr form)))) + (setq elint-env (elint-env-add-func elint-env (cadr form) '(event)) + elint-env (elint-env-add-var elint-env (cadr form)))) ;; FIXME it would be nice to check the autoloads are correct. ((eq (car form) 'autoload) - (setq env (elint-env-add-func env (cadr (cadr form)) 'unknown))) + (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) 'unknown))) ((eq (car form) 'declare-function) - (setq env (elint-env-add-func - env (cadr form) + (setq elint-env (elint-env-add-func + elint-env (cadr form) (if (or (< (length form) 4) (eq (nth 3 form) t) (unless (stringp (nth 2 form)) @@ -440,14 +440,14 @@ Return nil if there are no more forms, t otherwise." ;; If the alias points to something already in the environment, ;; add the alias to the environment with the same arguments. ;; FIXME symbol-function, eg backquote.el? - (let ((def (elint-env-find-func env (cadr (nth 2 form))))) - (setq env (elint-env-add-func env (cadr (cadr form)) + (let ((def (elint-env-find-func elint-env (cadr (nth 2 form))))) + (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) (if def (cadr def) 'unknown))))) ;; Add macro, both as a macro and as a function ((eq (car form) 'defmacro) - (setq env (elint-env-add-macro env (cadr form) + (setq elint-env (elint-env-add-macro elint-env (cadr form) (cons 'lambda (cddr form))) - env (elint-env-add-func env (cadr form) (nth 2 form)))) + elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form)))) ((and (eq (car form) 'put) (= 4 (length form)) (eq (car-safe (cadr form)) 'quote) @@ -471,12 +471,12 @@ Return nil if there are no more forms, t otherwise." (setq name 'cl-macs file nil elint-doing-cl t)) ; blech - (setq env (elint-add-required-env env name file)))))) - env) + (setq elint-env (elint-add-required-env elint-env name file)))))) + elint-env) (defun elint-init-env (forms) "Initialize the environment from FORMS." - (let ((env (elint-make-env)) + (let ((elint-env (elint-make-env)) form) (while forms (setq form (elint-top-form-form (car forms)) @@ -489,7 +489,7 @@ Return nil if there are no more forms, t otherwise." with-no-warnings)) (mapc 'elint-init-form (cdr form)) (elint-init-form form))) - env)) + elint-env)) (defun elint-add-required-env (env name file) "Augment ENV with the variables defined by feature NAME in FILE." @@ -1171,5 +1171,4 @@ If no documentation could be found args will be `unknown'." (provide 'elint) -;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f ;;; elint.el ends here diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 9a665272851..910eff3c78f 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,7 +1,7 @@ ;;; elp.el --- Emacs Lisp Profiler -;; Copyright (C) 1994, 1995, 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1994-1995, 1997-1998, 2001-2011 +;; Free Software Foundation, Inc. ;; Author: Barry A. Warsaw ;; Maintainer: FSF @@ -660,5 +660,4 @@ displayed." (provide 'elp) -;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1 ;;; elp.el ends here diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el new file mode 100644 index 00000000000..39d4a4e814a --- /dev/null +++ b/lisp/emacs-lisp/ert-x.el @@ -0,0 +1,290 @@ +;;; ert-x.el --- Staging area for experimental extensions to ERT + +;; Copyright (C) 2008, 2010-2011 Free Software Foundation, Inc. + +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Author: Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; This program 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. +;; +;; This program 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 this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file includes some extra helper functions to use while writing +;; automated tests with ERT. These have been proposed as extensions +;; to ERT but are not mature yet and likely to change. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'ert) + + +;;; Test buffers. + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "<anonymous test>") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(defmacro* ert-with-test-buffer ((&key ((:name name-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test +buffer is killed; if there is an error, the test buffer is kept +around on error for further inspection. Its name is derived from +the name of the test and the result of NAME-FORM." + (declare (debug ((form) body)) + (indent 1)) + `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-with-test-buffer 'lisp-indent-function 1)) + +;;;###autoload +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + + +;;; Simulate commands. + +(defun ert-simulate-command (command) + ;; FIXME: add unread-events + "Simulate calling COMMAND the way the Emacs command loop would call it. + +This effectively executes + + \(apply (car COMMAND) (cdr COMMAND)\) + +and returns the same value, but additionally runs hooks like +`pre-command-hook' and `post-command-hook', and sets variables +like `this-command' and `last-command'. + +COMMAND should be a list where the car is the command symbol and +the rest are arguments to the command. + +NOTE: Since the command is not called by `call-interactively' +test for `called-interactively' in the command will fail." + (assert (listp command) t) + (assert (commandp (car command)) t) + (assert (not unread-command-events) t) + (let (return-value) + ;; For the order of things here see command_loop_1 in keyboard.c. + ;; + ;; The command loop will reset the command-related variables so + ;; there is no reason to let-bind them. They are set here, + ;; however, to be able to test several commands in a row and how + ;; they affect each other. + (setq deactivate-mark nil + this-original-command (car command) + ;; remap through active keymaps + this-command (or (command-remapping this-original-command) + this-original-command)) + (run-hooks 'pre-command-hook) + (setq return-value (apply (car command) (cdr command))) + (run-hooks 'post-command-hook) + (when deferred-action-list + (run-hooks 'deferred-action-function)) + (setq real-last-command (car command) + last-command this-command) + (when (boundp 'last-repeatable-command) + (setq last-repeatable-command real-last-command)) + (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) + (assert (not unread-command-events) t) + return-value)) + +(defun ert-run-idle-timers () + "Run all idle timers (from `timer-idle-list')." + (dolist (timer (copy-sequence timer-idle-list)) + (timer-event-handler timer))) + + +;;; Miscellaneous utilities. + +(defun ert-filter-string (s &rest regexps) + "Return a copy of S with all matches of REGEXPS removed. + +Elements of REGEXPS may also be two-element lists \(REGEXP +SUBEXP\), where SUBEXP is the number of a subexpression in +REGEXP. In that case, only that subexpression will be removed +rather than the entire match." + ;; Use a temporary buffer since replace-match copies strings, which + ;; would lead to N^2 runtime. + (with-temp-buffer + (insert s) + (dolist (x regexps) + (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match "" t t nil subexp)))) + (buffer-string))) + + +(defun ert-propertized-string (&rest args) + "Return a string with properties as specified by ARGS. + +ARGS is a list of strings and plists. The strings in ARGS are +concatenated to produce an output string. In the output string, +each string from ARGS will be have the preceding plist as its +property list, or no properties if there is no plist before it. + +As a simple example, + +\(ert-propertized-string \"foo \" '(face italic) \"bar\" \" baz\" nil \ +\" quux\"\) + +would return the string \"foo bar baz quux\" where the substring +\"bar baz\" has a `face' property with the value `italic'. + +None of the ARGS are modified, but the return value may share +structure with the plists in ARGS." + (with-temp-buffer + (loop with current-plist = nil + for x in args do + (etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) + (buffer-string))) + + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (lexical-let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) + + +(defun ert-buffer-string-reindented (&optional buffer) + "Return the contents of BUFFER after reindentation. + +BUFFER defaults to current buffer. Does not modify BUFFER." + (with-current-buffer (or buffer (current-buffer)) + (let ((clone nil)) + (unwind-protect + (progn + ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil. + (let ((buffer-file-name nil)) + (setq clone (clone-buffer))) + (with-current-buffer clone + (let ((inhibit-read-only t)) + (indent-region (point-min) (point-max))) + (buffer-string))) + (when clone + (let ((kill-buffer-query-functions nil)) + (kill-buffer clone))))))) + + +(provide 'ert-x) + +;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el new file mode 100644 index 00000000000..7ee81463236 --- /dev/null +++ b/lisp/emacs-lisp/ert.el @@ -0,0 +1,2544 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007-2008, 2010-2011 Free Software Foundation, Inc. + +;; Author: Christian Ohler <ohler@gnu.org> +;; Keywords: lisp, tools + +;; This file is part of GNU Emacs. + +;; This program 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. +;; +;; This program 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 this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-not-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +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...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-not-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-not-equal (a b) + "Explainer function for `equal'. + +Returns a programmer-readable explanation of why A and B are not +`equal', or nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (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))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-not-equal (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (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 + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (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))))) +(put 'equal 'ert-explainer 'ert--explain-not-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-not-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-not-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-not-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-not-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (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. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +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 + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (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 + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (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? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the tool detected an error outside +of the tests (e.g. invalid SELECTOR or bug in the code that runs +the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +(loop for (key binding) in + '(("q" quit-window) + ) + do + (define-key ert-simple-view-mode-map key binding)) + + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("q" quit-window) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "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 signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "<anonymous test>")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 9928f8f75c0..bf9998695ee 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,7 +1,6 @@ ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1991-2011 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> @@ -578,5 +577,4 @@ Return nil if the buffer has been deleted." ;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2) ;; End: -;; arch-tag: d78915b9-9a07-44bf-aac6-04a1fc1bd6d4 ;;; ewoc.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 94cb0bfe2d2..9c4a3e9832c 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,7 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc. ;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp> ;; Maintainer: petersen@kurims.kyoto-u.ac.jp @@ -213,6 +212,8 @@ LIBRARY should be a string (the name of the library)." (interactive (let* ((dirs (or find-function-source-path load-path)) (suffixes (find-library-suffixes)) + (table (apply-partially 'locate-file-completion-table + dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -226,16 +227,12 @@ LIBRARY should be a string (the name of the library)." (thing-at-point 'symbol)) (error nil)) (thing-at-point 'symbol)))) - (when def - (setq def (and (locate-file-completion-table - dirs suffixes def nil 'lambda) - def))) + (when (and def (not (test-completion def table))) + (setq def nil)) (list (completing-read (if def (format "Library name (default %s): " def) "Library name: ") - (apply-partially 'locate-file-completion-table - dirs suffixes) - nil nil nil nil def)))) + 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))))) @@ -565,5 +562,4 @@ Set mark before moving, if the buffer already existed." (provide 'find-func) -;; arch-tag: 43ecd81c-74dc-4d9a-8f63-a61e55670d64 ;;; find-func.el ends here diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index 7f4d8918a35..773b8f11408 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -1,7 +1,6 @@ ;;; find-gc.el --- detect functions that call the garbage collector -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc. ;; Maintainer: FSF @@ -60,7 +59,7 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).") "indent.c" "search.c" "regex.c" "undo.c" "alloc.c" "data.c" "doc.c" "editfns.c" "callint.c" "eval.c" "fns.c" "print.c" "lread.c" - "abbrev.c" "syntax.c" "unexec.c" + "abbrev.c" "syntax.c" "unexcoff.c" "bytecode.c" "process.c" "callproc.c" "doprnt.c" "x11term.c" "x11fns.c")) @@ -159,5 +158,4 @@ Also store it in `find-gc-unsafe'." (provide 'find-gc) -;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 ;;; find-gc.el ends here diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index f7e540237be..ceb1eb3bafb 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,10 +1,10 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 2001-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -25,36 +25,27 @@ ;;; Code: -;; Provide a meaningful error message if we are running on -;; bare (non-float) emacs. - -(if (fboundp 'atan) - nil - (error "Floating point was disabled at compile time")) - -;; provide an easy hook to tell if we are running with floats or not. -;; define pi and e via math-lib calls. (much less prone to killer typos.) +;; Provide an easy hook to tell if we are running with floats or not. +;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") (defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") (defconst float-e (exp 1) "The value of e (2.7182818...).") -(defvar e float-e "Obsolete since Emacs-23.3. Use `float-e' instead.") (defconst degrees-to-radians (/ float-pi 180.0) "Degrees to radian conversion constant.") (defconst radians-to-degrees (/ 180.0 float-pi) "Radian to degree conversion constant.") -;; these expand to a single multiply by a float when byte compiled +;; These expand to a single multiply by a float when byte compiled. (defmacro degrees-to-radians (x) - "Convert ARG from degrees to radians." + "Convert X from degrees to radians." (list '* degrees-to-radians x)) (defmacro radians-to-degrees (x) - "Convert ARG from radians to degrees." + "Convert X from radians to degrees." (list '* radians-to-degrees x)) (provide 'lisp-float-type) -;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d ;;; float-sup.el ends here diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 6b28e931603..770fe01f91c 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,11 +1,11 @@ ;;; generic.el --- defining simple major modes with comment and font-lock ;; -;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2011 Free Software Foundation, Inc. ;; ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 ;; Keywords: generic, comment, font-lock +;; Package: emacs ;; This file is part of GNU Emacs. @@ -315,5 +315,4 @@ regular expression that can be used as an element of (provide 'generic) -;; arch-tag: 239c1fc4-1303-48d9-9ac0-657d655669ea ;;; generic.el ends here diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index fe8c6e7fae6..eca5470fd69 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -1,7 +1,6 @@ ;;; gulp.el --- ask for updates for Lisp packages -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc. ;; Author: Sam Shteingold <shteingd@math.ucla.edu> ;; Maintainer: FSF @@ -175,5 +174,4 @@ That is a list of elements, each of the form (MAINTAINER PACKAGES...)." (provide 'gulp) -;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5 ;;; gulp.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 5935d544974..113f5849364 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,11 +1,11 @@ ;;; helper.el --- utility help package supporting help in electric modes -;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2011 Free Software Foundation, Inc. ;; Author: K. Shane Hartman ;; Maintainer: FSF ;; Keywords: help +;; Package: emacs ;; This file is part of GNU Emacs. @@ -155,5 +155,4 @@ (provide 'helper) -;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9 ;;; helper.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 9e1e26778b7..4d0cacf4ee1 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,7 +1,6 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1994, 1997, 2000-2011 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Maintainer: FSF @@ -298,6 +297,7 @@ The returned value is a list of strings, one per line." (defmacro lm-with-file (file &rest body) "Execute BODY in a buffer containing the contents of FILE. If FILE is nil, execute BODY in the current buffer." + (declare (indent 1) (debug t)) (let ((filesym (make-symbol "file"))) `(let ((,filesym ,file)) (if ,filesym @@ -311,9 +311,6 @@ If FILE is nil, execute BODY in the current buffer." (with-syntax-table emacs-lisp-mode-syntax-table ,@body)))))) -(put 'lm-with-file 'lisp-indent-function 1) -(put 'lm-with-file 'edebug-form-spec t) - ;; Fixme: Probably this should be amalgamated with copyright.el; also ;; we need a check for ranges in copyright years. @@ -458,7 +455,9 @@ each line." "Return list of keywords given in file FILE." (let ((keywords (lm-keywords file))) (if keywords - (split-string keywords "[, \t\n]+" t)))) + (if (string-match-p "," keywords) + (split-string keywords ",[ \t\n]*" t) + (split-string keywords "[ \t\n]+" t))))) (defvar finder-known-keywords) (defun lm-keywords-finder-p (&optional file) @@ -616,5 +615,4 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (provide 'lisp-mnt) -;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e ;;; lisp-mnt.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 8626c34f77c..15690023700 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,10 +1,10 @@ ;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -;; Copyright (C) 1985, 1986, 1999, 2000, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1999-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -85,7 +85,7 @@ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\[ "_ " table) (modify-syntax-entry ?\] "_ " table) - (modify-syntax-entry ?# "' 14b" table) + (modify-syntax-entry ?# "' 14" table) (modify-syntax-entry ?| "\" 23bn" table) table) "Syntax table used in `lisp-mode'.") @@ -221,8 +221,6 @@ font-lock keywords will not be case sensitive." ;;(set (make-local-variable 'adaptive-fill-mode) nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) (make-local-variable 'outline-regexp) (setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") (make-local-variable 'outline-level) @@ -408,10 +406,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (if (and (buffer-modified-p) (y-or-n-p (format "Save buffer %s first? " (buffer-name)))) (save-buffer)) - (let ((compiled-file-name (byte-compile-dest-file buffer-file-name))) - (if (file-newer-than-file-p compiled-file-name buffer-file-name) - (load-file compiled-file-name) - (byte-compile-file buffer-file-name t)))) + (byte-recompile-file buffer-file-name nil 0 t)) (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." @@ -431,7 +426,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :type 'hook :group 'lisp) -(define-derived-mode emacs-lisp-mode nil "Emacs-Lisp" +(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. @@ -466,7 +461,7 @@ if that value is non-nil." "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(defun lisp-mode () +(define-derived-mode lisp-mode prog-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -478,19 +473,12 @@ or to switch back to an existing one. Entry to this mode calls the value of `lisp-mode-hook' if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-mode-map) - (setq major-mode 'lisp-mode) - (setq mode-name "Lisp") (lisp-mode-variables nil t) + (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default) (make-local-variable 'comment-start-skip) (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") - (setq imenu-case-fold-search t) - (set-syntax-table lisp-mode-syntax-table) - (run-mode-hooks 'lisp-mode-hook)) -(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default) + (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () (let ((default (find-tag-default))) @@ -1078,7 +1066,7 @@ is the buffer position of the start of the containing expression." (goto-char calculate-lisp-indent-last-sexp) (or (and (looking-at ":") (setq indent (current-column))) - (and (< (save-excursion (beginning-of-line) (point)) + (and (< (line-beginning-position) (prog2 (backward-sexp) (point))) (looking-at ":") (setq indent (current-column)))) @@ -1218,31 +1206,17 @@ This function also returns nil meaning don't specify the indentation." (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) (put 'save-window-excursion 'lisp-indent-function 0) -(put 'save-selected-window 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) -(put 'with-current-buffer 'lisp-indent-function 1) -(put 'combine-after-change-calls 'lisp-indent-function 0) -(put 'with-output-to-string 'lisp-indent-function 0) -(put 'with-temp-file 'lisp-indent-function 1) -(put 'with-temp-buffer 'lisp-indent-function 0) -(put 'with-temp-message 'lisp-indent-function 1) -(put 'with-syntax-table 'lisp-indent-function 1) (put 'let 'lisp-indent-function 1) (put 'let* 'lisp-indent-function 1) (put 'while 'lisp-indent-function 1) (put 'if 'lisp-indent-function 2) -(put 'read-if 'lisp-indent-function 2) (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) -(put 'eval-after-load 'lisp-indent-function 1) -(put 'dolist 'lisp-indent-function 1) -(put 'dotimes 'lisp-indent-function 1) -(put 'when 'lisp-indent-function 1) -(put 'unless 'lisp-indent-function 1) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. @@ -1454,5 +1428,4 @@ means don't indent that line." (provide 'lisp-mode) -;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf ;;; lisp-mode.el ends here diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 822c2d30fbe..deb06f52549 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,10 +1,10 @@ ;;; lisp.el --- Lisp editing commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1994, 2000-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -140,9 +140,19 @@ A negative argument means move backward but still to a less deep spot. This command assumes point is not in a string or comment." (interactive "^p") (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) + (let ((inc (if (> arg 0) 1 -1)) + pos) (while (/= arg 0) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) + (if (null forward-sexp-function) + (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) + (condition-case err + (while (progn (setq pos (point)) + (forward-sexp inc) + (/= (point) pos))) + (scan-error (goto-char (nth 2 err)))) + (if (= (point) pos) + (signal 'scan-error + (list "Unbalanced parentheses" (point) (point))))) (setq arg (- arg inc))))) (defun kill-sexp (&optional arg) @@ -624,45 +634,59 @@ considered." (interactive) (let* ((data (lisp-completion-at-point predicate)) (plist (nthcdr 3 data))) - (let ((completion-annotate-function (plist-get plist :annotate-function))) + (if (null data) + (minibuffer-message "Nothing to complete") + (let ((completion-annotate-function + (plist-get plist :annotate-function))) (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) - (plist-get plist :predicate))))) + (plist-get plist :predicate)))))) (defun lisp-completion-at-point (&optional predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." ;; FIXME: the `end' could be after point? (with-syntax-table emacs-lisp-mode-syntax-table - (let* ((end (point)) - (beg (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point))) - (predicate - (or predicate - (save-excursion - (goto-char beg) - (if (not (eq (char-before) ?\()) - (lambda (sym) ;why not just nil ? -sm - (or (boundp sym) (fboundp sym) - (symbol-plist sym))) - ;; Looks like a funcall position. Let's double check. - (if (condition-case nil - (progn (up-list -2) (forward-char 1) - (eq (char-after) ?\()) - (error nil)) - ;; If the first element of the parent list is an open - ;; paren we are probably not in a funcall position. - ;; Maybe a `let' varlist or something. - nil - ;; Else, we assume that a function name is expected. - 'fboundp)))))) - (list beg end obarray - :predicate predicate - :annotate-function - (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))) - -;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e + (let* ((pos (point)) + (beg (condition-case nil + (save-excursion + (backward-sexp 1) + (skip-syntax-forward "'") + (point)) + (scan-error pos))) + (predicate + (or predicate + (save-excursion + (goto-char beg) + (if (not (eq (char-before) ?\()) + (lambda (sym) ;why not just nil ? -sm + (or (boundp sym) (fboundp sym) + (symbol-plist sym))) + ;; Looks like a funcall position. Let's double check. + (if (condition-case nil + (progn (up-list -2) (forward-char 1) + (eq (char-after) ?\()) + (error nil)) + ;; If the first element of the parent list is an open + ;; paren we are probably not in a funcall position. + ;; Maybe a `let' varlist or something. + nil + ;; Else, we assume that a function name is expected. + 'fboundp))))) + (end + (unless (or (eq beg (point-max)) + (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) + (condition-case nil + (save-excursion + (goto-char beg) + (forward-sexp 1) + (when (>= (point) pos) + (point))) + (scan-error pos))))) + (when end + (list beg end obarray + :predicate predicate + :annotate-function + (unless (eq predicate 'fboundp) + (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))) + ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index cdbbe52d0a8..af8047256e2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ ;;; macroexp.el --- Additional macro-expansion support ;; -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2004-2011 Free Software Foundation, Inc. ;; ;; Author: Miles Bader <miles@gnu.org> ;; Keywords: lisp, compiler, macros @@ -52,6 +52,7 @@ possible (for instance, when BODY just returns VAR unchanged, the result will be eq to LIST). \(fn (VAR LIST) BODY...)" + (declare (indent 1)) (let ((var (car var+list)) (list (cadr var+list)) (shared (make-symbol "shared")) @@ -72,7 +73,6 @@ result will be eq to LIST). (push ,new-el ,unshared)) (setq ,tail (cdr ,tail))) (nconc (nreverse ,unshared) ,shared)))) -(put 'macroexp-accumulate 'lisp-indent-function 1) (defun macroexpand-all-forms (forms &optional skip) "Return FORMS with macros expanded. FORMS is a list of forms. @@ -107,80 +107,69 @@ Assumes the caller has bound `macroexpand-all-environment'." macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. (setq form (macroexpand form macroexpand-all-environment)) - (if (consp form) - (let ((fun (car form))) - (cond - ((eq fun 'cond) - (maybe-cons fun (macroexpand-all-clauses (cdr form)) form)) - ((eq fun 'condition-case) - (maybe-cons - fun - (maybe-cons (cadr form) - (maybe-cons (macroexpand-all-1 (nth 2 form)) - (macroexpand-all-clauses (nthcdr 3 form) 1) - (cddr form)) - (cdr form)) - form)) - ((eq fun 'defmacro) - (push (cons (cadr form) (cons 'lambda (cddr form))) - macroexpand-all-environment) - (macroexpand-all-forms form 3)) - ((eq fun 'defun) - (macroexpand-all-forms form 3)) - ((memq fun '(defvar defconst)) - (macroexpand-all-forms form 2)) - ((eq fun 'function) - (if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) - (maybe-cons fun - (maybe-cons (macroexpand-all-forms (cadr form) 2) - nil - (cadr form)) - form) - form)) - ((memq fun '(let let*)) - (maybe-cons fun - (maybe-cons (macroexpand-all-clauses (cadr form) 1) - (macroexpand-all-forms (cddr form)) - (cdr form)) - form)) - ((eq fun 'quote) - form) - ((and (consp fun) (eq (car fun) 'lambda)) - ;; embedded lambda - (maybe-cons (macroexpand-all-forms fun 2) - (macroexpand-all-forms (cdr form)) - form)) - ;; The following few cases are for normal function calls that - ;; are known to funcall one of their arguments. The byte - ;; compiler has traditionally handled these functions specially - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - ((and (memq fun '(apply mapcar mapatoms mapconcat mapc)) - (consp (cadr form)) - (eq (car (cadr form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cons 'function (cdr (cadr form)))) - (macroexpand-all-forms (cddr form))))) - ;; Second arg is a function: - ((and (eq fun 'sort) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cadr form)) - (cons (macroexpand-all-1 - (cons 'function (cdr (nth 2 form)))) - (macroexpand-all-forms (nthcdr 3 form)))))) - (t - ;; For everything else, we just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexpand-all-forms form 1)))) - form))) + (pcase form + (`(cond . ,clauses) + (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) + (maybe-cons + 'condition-case + (maybe-cons err + (maybe-cons (macroexpand-all-1 body) + (macroexpand-all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(defmacro ,name . ,args-and-body) + (push (cons name (cons 'lambda args-and-body)) + macroexpand-all-environment) + (macroexpand-all-forms form 3)) + (`(defun . ,_) (macroexpand-all-forms form 3)) + (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (maybe-cons 'function + (maybe-cons (macroexpand-all-forms f 2) + nil + (cdr form)) + form)) + (`(,(or `function `quote) . ,_) form) + (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) + (maybe-cons fun + (maybe-cons (macroexpand-all-clauses bindings 1) + (macroexpand-all-forms body) + (cdr form)) + form)) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + (maybe-cons (macroexpand-all-forms fun 2) + (macroexpand-all-forms args) + form)) + ;; The following few cases are for normal function calls that + ;; are known to funcall one of their arguments. The byte + ;; compiler has traditionally handled these functions specially + ;; by treating a lambda expression quoted by `quote' as if it + ;; were quoted by `function'. We make the same transformation + ;; here, so that any code that cares about the difference will + ;; see the same transformation. + ;; First arg is a function: + (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 (list 'function f)) + (macroexpand-all-forms args)))) + ;; Second arg is a function: + (`(,(and fun (or `sort)) ,arg1 ',f . ,args) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 arg1) + (cons (macroexpand-all-1 + (list 'function f)) + (macroexpand-all-forms args))))) + (`(,_ . ,_) + ;; For every other list, we just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexpand-all-forms form 1)) + (t form)))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -193,5 +182,4 @@ definitions to shadow the loaded ones for use in file byte-compilation." (provide 'macroexp) -;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a ;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index aefc631c3ba..6ef26fef89c 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -1,7 +1,6 @@ ;;; map-ynp.el --- general-purpose boolean question-asker -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1991-1995, 2000-2011 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: FSF @@ -275,5 +274,4 @@ the current %s and exit." ;; Return the number of actions that were taken. actions)) -;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3 ;;; map-ynp.el ends here diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el new file mode 100644 index 00000000000..b9994be3d39 --- /dev/null +++ b/lisp/emacs-lisp/package-x.el @@ -0,0 +1,227 @@ +;;; package-x.el --- Package extras + +;; Copyright (C) 2007-2011 Free Software Foundation, Inc. + +;; Author: Tom Tromey <tromey@redhat.com> +;; Created: 10 Mar 2007 +;; Version: 0.9 +;; Keywords: tools +;; Package: package + +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file currently contains parts of the package system most +;; people won't need, such as package uploading. + +;;; Code: + +(require 'package) +(defvar gnus-article-buffer) + +;; Note that this only works if you have the password, which you +;; probably don't :-). +(defvar package-archive-upload-base nil + "Base location for uploading to package archive.") + +(defun package--encode (string) + "Encode a string by replacing some characters with XML entities." + ;; We need a special case for translating "&" to "&". + (let ((index)) + (while (setq index (string-match "[&]" string index)) + (setq string (replace-match "&" t nil string)) + (setq index (1+ index)))) + (while (string-match "[<]" string) + (setq string (replace-match "<" t nil string))) + (while (string-match "[>]" string) + (setq string (replace-match ">" t nil string))) + (while (string-match "[']" string) + (setq string (replace-match "'" t nil string))) + (while (string-match "[\"]" string) + (setq string (replace-match """ t nil string))) + string) + +(defun package--make-rss-entry (title text archive-url) + (let ((date-string (format-time-string "%a, %d %B %Y %T %z"))) + (concat "<item>\n" + "<title>" (package--encode title) "</title>\n" + ;; FIXME: should have a link in the web page. + "<link>" archive-url "news.html</link>\n" + "<description>" (package--encode text) "</description>\n" + "<pubDate>" date-string "</pubDate>\n" + "</item>\n"))) + +(defun package--make-html-entry (title text) + (concat "<li> " (format-time-string "%B %e") " - " + title " - " (package--encode text) + " </li>\n")) + +(defun package--update-file (file location text) + (save-excursion + (let ((old-buffer (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (or old-buffer (find-file-noselect file))) + (goto-char (point-min)) + (search-forward location) + (forward-line) + (insert text) + (let ((file-precious-flag t)) + (save-buffer)) + (unless old-buffer + (kill-buffer (current-buffer))))))) + +(defun package-maint-add-news-item (title description archive-url) + "Add a news item to the ELPA web pages. +TITLE is the title of the news item. +DESCRIPTION is the text of the news item. +You need administrative access to ELPA to use this." + (interactive "sTitle: \nsText: ") + (package--update-file (concat package-archive-upload-base "elpa.rss") + "<description>" + (package--make-rss-entry title description archive-url)) + (package--update-file (concat package-archive-upload-base "news.html") + "New entries go here" + (package--make-html-entry title description))) + +(defun package--update-news (package version description archive-url) + "Update the ELPA web pages when a package is uploaded." + (package-maint-add-news-item (concat package " version " version) + description + archive-url)) + +(defun package-upload-buffer-internal (pkg-info extension &optional archive-url) + "Upload a package whose contents are in the current buffer. +PKG-INFO is the package info, see `package-buffer-info'. +EXTENSION is the file extension, a string. It can be either +\"el\" or \"tar\". + +Optional arg ARCHIVE-URL is the URL of the destination archive. +If nil, the \"gnu\" archive is used." + (unless archive-url + (or (setq archive-url (cdr (assoc "gnu" package-archives))) + (error "No destination URL"))) + (save-excursion + (save-restriction + (let* ((file-type (cond + ((equal extension "el") 'single) + ((equal extension "tar") 'tar) + (t (error "Unknown extension `%s'" extension)))) + (file-name (aref pkg-info 0)) + (pkg-name (intern file-name)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + (read-string "Description of package: ") + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3)) + (commentary (aref pkg-info 4)) + (split-version (version-to-list pkg-version)) + (pkg-buffer (current-buffer)) + + ;; Download latest archive-contents. + (buffer (url-retrieve-synchronously + (concat archive-url "archive-contents")))) + + ;; Parse archive-contents. + (set-buffer buffer) + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (let ((contents (package-read-from-string + (buffer-substring-no-properties (point-min) + (point-max)))) + (new-desc (vector split-version requires desc file-type))) + (if (> (car contents) package-archive-version) + (error "Unrecognized archive version %d" (car contents))) + (let ((elt (assq pkg-name (cdr contents)))) + (if elt + (if (version-list-<= split-version + (package-desc-vers (cdr elt))) + (error "New package has smaller version: %s" pkg-version) + (setcdr elt new-desc)) + (setq contents (cons (car contents) + (cons (cons pkg-name new-desc) + (cdr contents)))))) + + ;; Now CONTENTS is the updated archive contents. Upload + ;; this and the package itself. For now we assume ELPA is + ;; writable via file primitives. + (let ((print-level nil) + (print-length nil)) + (write-region (concat (pp-to-string contents) "\n") + nil + (concat package-archive-upload-base + "archive-contents"))) + + ;; If there is a commentary section, write it. + (when commentary + (write-region commentary nil + (concat package-archive-upload-base + (symbol-name pkg-name) "-readme.txt"))) + + (set-buffer pkg-buffer) + (kill-buffer buffer) + (write-region (point-min) (point-max) + (concat package-archive-upload-base + file-name "-" pkg-version + "." extension) + nil nil nil 'excl) + + ;; Write a news entry. + (package--update-news (concat file-name "." extension) + pkg-version desc archive-url) + + ;; special-case "package": write a second copy so that the + ;; installer can easily find the latest version. + (if (string= file-name "package") + (write-region (point-min) (point-max) + (concat package-archive-upload-base + file-name "." extension) + nil nil nil 'ask))))))) + +(defun package-upload-buffer () + "Upload a single .el file to ELPA from the current buffer." + (interactive) + (save-excursion + (save-restriction + ;; Find the package in this buffer. + (let ((pkg-info (package-buffer-info))) + (package-upload-buffer-internal pkg-info "el"))))) + +(defun package-upload-file (file) + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (let ((info (cond + ((string-match "\\.tar$" file) (package-tar-file-info file)) + ((string-match "\\.el$" file) (package-buffer-info)) + (t (error "Unrecognized extension `%s'" + (file-name-extension file)))))) + (package-upload-buffer-internal info (file-name-extension file))))) + +(defun package-gnus-summary-upload () + "Upload a package contained in the current *Article* buffer. +This should be invoked from the gnus *Summary* buffer." + (interactive) + (with-current-buffer gnus-article-buffer + (package-upload-buffer))) + +(provide 'package-x) + +;;; package.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el new file mode 100644 index 00000000000..59964ff6b96 --- /dev/null +++ b/lisp/emacs-lisp/package.el @@ -0,0 +1,1700 @@ +;;; package.el --- Simple package system for Emacs + +;; Copyright (C) 2007-2011 Free Software Foundation, Inc. + +;; Author: Tom Tromey <tromey@redhat.com> +;; Created: 10 Mar 2007 +;; Version: 0.9 +;; Keywords: tools + +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; 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 +;; install them. Packages are versioned and have versioned +;; dependencies. Furthermore, this supports built-in packages which +;; may or may not be newer than user-specified packages. This makes +;; it possible to upgrade Emacs and automatically disable packages +;; which have moved from external to core. (Note though that we don't +;; currently register any of these, so this feature does not actually +;; work.) + +;; A package is described by its name and version. The distribution +;; format is either a tar file or a single .el file. + +;; A tar file should be named "NAME-VERSION.tar". The tar file must +;; unpack into a directory named after the package and version: +;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el" +;; which consists of a call to define-package. It may also contain a +;; "dir" file and the info files it references. + +;; A .el file is named "NAME-VERSION.el" in the remote archive, but is +;; installed as simply "NAME.el" in a directory named "NAME-VERSION". + +;; The downloader downloads all dependent packages. By default, +;; packages come from the official GNU sources, but others may be +;; added by customizing the `package-archives' alist. Packages get +;; byte-compiled at install time. + +;; At activation time we will set up the load-path and the info path, +;; and we will load the package's autoloads. If a package's +;; dependencies are not available, we will not activate that package. + +;; Conceptually a package has multiple state transitions: +;; +;; * Download. Fetching the package from ELPA. +;; * Install. Untar the package, or write the .el file, into +;; ~/.emacs.d/elpa/ directory. +;; * Byte compile. Currently this phase is done during install, +;; but we may change this. +;; * Activate. Evaluate the autoloads for the package to make it +;; available to the user. +;; * Load. Actually load the package and run some code from it. + +;; Other external functions you may want to use: +;; +;; M-x list-packages +;; Enters a mode similar to buffer-menu which lets you manage +;; packages. You can choose packages for install (mark with "i", +;; then "x" to execute) or deletion (not implemented yet), and you +;; can see what packages are available. This will automatically +;; fetch the latest list of packages from ELPA. +;; +;; M-x package-list-packages-no-fetch +;; Like package-list-packages, but does not automatically fetch the +;; new list of packages. +;; +;; M-x package-install-from-buffer +;; Install a package consisting of a single .el file that appears +;; in the current buffer. This only works for packages which +;; define a Version header properly; package.el also supports the +;; extension headers Package-Version (in case Version is an RCS id +;; or similar), and Package-Requires (if the package requires other +;; packages). +;; +;; M-x package-install-file +;; Install a package from the indicated file. The package can be +;; either a tar file or a .el file. A tar file must contain an +;; appropriately-named "-pkg.el" file; a .el file must be properly +;; formatted as with package-install-from-buffer. + +;;; Thanks: +;;; (sorted by sort-lines): + +;; Jim Blandy <jimb@red-bean.com> +;; Karl Fogel <kfogel@red-bean.com> +;; Kevin Ryde <user42@zip.com.au> +;; Lawrence Mitchell +;; Michael Olson <mwolson@member.fsf.org> +;; Sebastian Tennant <sebyte@smolny.plus.com> +;; Stefan Monnier <monnier@iro.umontreal.ca> +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Phil Hagelberg <phil@hagelb.org> + +;;; ToDo: + +;; - putting info dirs at the start of the info path means +;; users see a weird ordering of categories. OTOH we want to +;; override later entries. maybe emacs needs to enforce +;; the standard layout? +;; - put bytecode in a separate directory tree +;; - perhaps give users a way to recompile their bytecode +;; or do it automatically when emacs changes +;; - give users a way to know whether a package is installed ok +;; - give users a way to view a package's documentation when it +;; only appears in the .el +;; - use/extend checkdoc so people can tell if their package will work +;; - "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 +;; works properly +;; - Implement M-x package-upgrade, to upgrade any/all existing packages +;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info +;; ... except maybe lisp? +;; - It may be nice to have a macro that expands to the package's +;; 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 optional package dependencies +;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb +;; and just don't compile to add to load path ...? +;; - Have a list of archive URLs? [ maybe there's no point ] +;; - David Kastrup pointed out on the xemacs list that for GPL it +;; is friendlier to ship the source tree. We could "support" that +;; by just having a "src" subdir in the package. This isn't ideal +;; but it probably is not worth trying to support random source +;; tree layouts, build schemes, etc. +;; - Our treatment of the info path is somewhat bogus +;; - perhaps have an "unstable" tree in ELPA as well as a stable one + +;;; Code: + +(defgroup package nil + "Manager for Emacs Lisp packages." + :group 'applications + :version "24.1") + +;;;###autoload +(defcustom package-enable-at-startup t + "Whether to activate installed packages when Emacs starts. +If non-nil, packages are activated after reading the init file +and before `after-init-hook'. Activation is not done if +`user-init-file' is nil (e.g. Emacs was started with \"-q\"). + +Even if the value is nil, you can type \\[package-initialize] to +activate the package system at any time." + :type 'boolean + :group 'package + :version "24.1") + +(defcustom package-load-list '(all) + "List of packages for `package-initialize' to load. +Each element in this list should be a list (NAME VERSION), or the +symbol `all'. The symbol `all' says to load the latest installed +versions of all packages not specified by other elements. + +For an element (NAME VERSION), NAME is a package name (a symbol). +VERSION should be t, a string, or nil. +If VERSION is t, all versions are loaded, though obsolete ones + will be put in `package-obsolete-alist' and not activated. +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) + :risky t + :group 'package + :version "24.1") + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) +(declare-function url-http-parse-response "url-http" ()) +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-commentary "lisp-mnt" (&optional file)) +(defvar url-http-end-of-headers) + +(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) + "An alist of archives from which to fetch. +The default value points to the GNU Emacs package repository. +Each element has the form (ID . URL), where ID is an identifier +string for an archive and URL is a http: URL (a string)." + :type '(alist :key-type (string :tag "Archive name") + :value-type (string :tag "Archive URL")) + :risky t + :group 'package + :version "24.1") + +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +(defconst package-el-version "1.0" + "Version of package.el.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents nil + "Cache of the contents of the Emacs Lisp Package Archive. +This is an alist mapping package names (symbols) to package +descriptor vectors. These are like the vectors for `package-alist' +but have extra entries: one which is 'tar for tar packages and +'single for single-file packages, and one which is the name of +the archive from which it came.") +(put 'package-archive-contents 'risky-local-variable t) + +(defcustom package-user-dir (locate-user-emacs-file "elpa") + "Directory containing the user's Emacs Lisp packages. +The directory name should be absolute. +Apart from this directory, Emacs also looks for system-wide +packages in `package-directory-list'." + :type 'directory + :risky t + :group 'package + :version "24.1") + +(defcustom package-directory-list + ;; Defaults are subdirs named "elpa" in the site-lisp dirs. + (let (result) + (dolist (f load-path) + (and (stringp f) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) + (nreverse result)) + "List of additional directories containing Emacs Lisp packages. +Each directory name should be absolute. + +These directories contain packages intended for system-wide; in +contrast, `package-user-dir' contains packages for personal use." + :type '(repeat directory) + :risky t + :group 'package + :version "24.1") + +;; The value is precomputed in finder-inf.el, but don't load that +;; until it's needed (i.e. when `package-intialize' is called). +(defvar package--builtins nil + "Alist of built-in packages. +The actual value is initialized by loading the library +`finder-inf'; this is not done until it is needed, e.g. by the +function `package-built-in-p'. + +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. +The vector DESC has the form [VERSION REQS DOCSTRING]. + VERSION is a version list. + REQS is a list of packages (symbols) required by the package. + DOCSTRING is a brief description of the package.") +(put 'package--builtins 'risky-local-variable t) + +(defvar package-alist nil + "Alist of all packages available for activation. +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. + +The vector DESC has the form [VERSION REQS DOCSTRING]. + VERSION is a version list. + REQS is a list of packages (symbols) required by the package. + DOCSTRING is a brief description of the package. + +This variable is set automatically by `package-load-descriptor', +called via `package-initialize'. To change which packages are +loaded and/or activated, customize `package-load-list'.") +(put 'package-archive-contents 'risky-local-variable t) + +(defvar package-activated-list nil + "List of the names of currently activated packages.") +(put 'package-activated-list 'risky-local-variable t) + +(defvar package-obsolete-alist nil + "Representation of obsolete packages. +Like `package-alist', but maps package name to a second alist. +The inner alist is keyed by version.") +(put 'package-obsolete-alist 'risky-local-variable t) + +(defconst package-subdirectory-regexp + "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$" + "Regular expression matching the name of a package subdirectory. +The first subexpression is the package name. +The second subexpression is the version string.") + +(defun package-version-join (l) + "Turn a list of version numbers into a version string." + (mapconcat 'int-to-string l ".")) + +(defun package-strip-version (dirname) + "Strip the version from a combined package name and version. +E.g., if given \"quux-23.0\", will return \"quux\"" + (if (string-match package-subdirectory-regexp dirname) + (match-string 1 dirname))) + +(defun package-load-descriptor (dir package) + "Load the description file in directory DIR for package PACKAGE. +Here, PACKAGE is a string of the form NAME-VER, where NAME is the +package name and VER is its version." + (let* ((pkg-dir (expand-file-name package dir)) + (pkg-file (expand-file-name + (concat (package-strip-version package) "-pkg") + pkg-dir))) + (when (and (file-directory-p pkg-dir) + (file-exists-p (concat pkg-file ".el"))) + (load pkg-file nil t)))) + +(defun package-load-all-descriptors () + "Load descriptors for installed Emacs Lisp packages. +This looks for package subdirectories in `package-user-dir' and +`package-directory-list'. The variable `package-load-list' +controls which package subdirectories may be loaded. + +In each valid package subdirectory, this function loads the +description file containing a call to `define-package', which +updates `package-alist' and `package-obsolete-alist'." + (let ((all (memq 'all package-load-list)) + name version force) + (dolist (dir (cons package-user-dir package-directory-list)) + (when (file-directory-p dir) + (dolist (subdir (directory-files dir)) + (when (and (file-directory-p (expand-file-name subdir dir)) + (string-match package-subdirectory-regexp subdir)) + (setq name (intern (match-string 1 subdir)) + version (match-string 2 subdir) + force (assq name package-load-list)) + (when (cond + ((null force) + all) ; not in package-load-list + ((null (setq force (cadr force))) + nil) ; disabled + ((eq force t) + t) + ((stringp force) ; held + (version-list-= (version-to-list version) + (version-to-list force))) + (t + (error "Invalid element in `package-load-list'"))) + (package-load-descriptor dir subdir)))))))) + +(defsubst package-desc-vers (desc) + "Extract version from a package description vector." + (aref desc 0)) + +(defsubst package-desc-reqs (desc) + "Extract requirements from a package description vector." + (aref desc 1)) + +(defsubst package-desc-doc (desc) + "Extract doc string from a package description vector." + (aref desc 2)) + +(defsubst package-desc-kind (desc) + "Extract the kind of download from an archive package description vector." + (aref desc 3)) + +(defun package--dir (name version) + "Return the directory where a package is installed, or nil if none. +NAME and VERSION are both strings." + (let* ((subdir (concat name "-" version)) + (dir-list (cons package-user-dir package-directory-list)) + pkg-dir) + (while dir-list + (let ((subdir-full (expand-file-name subdir (car dir-list)))) + (if (file-directory-p subdir-full) + (setq pkg-dir subdir-full + dir-list nil) + (setq dir-list (cdr dir-list))))) + pkg-dir)) + +(defun package-activate-1 (package pkg-vec) + (let* ((name (symbol-name package)) + (version-str (package-version-join (package-desc-vers pkg-vec))) + (pkg-dir (package--dir name version-str))) + (unless pkg-dir + (error "Internal error: unable to find directory for `%s-%s'" + name version-str)) + ;; Add info node. + (when (file-exists-p (expand-file-name "dir" pkg-dir)) + ;; FIXME: not the friendliest, but simple. + (require 'info) + (info-initialize) + (push pkg-dir Info-directory-list)) + ;; Add to load path, add autoloads, and activate the package. + (push pkg-dir load-path) + (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) + (push package package-activated-list) + ;; Don't return nil. + t)) + +(defun package-built-in-p (package &optional version) + "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs." + (require 'finder-inf nil t) ; For `package--builtins'. + (let ((elt (assq package package--builtins))) + (and elt (version-list-<= version (package-desc-vers (cdr elt)))))) + +;; This function goes ahead and activates a newer version of a package +;; if an older one was already activated. This is not ideal; we'd at +;; least need to check to see if the package has actually been loaded, +;; and not merely activated. +(defun package-activate (package version) + "Activate package PACKAGE, of version VERSION or newer. +If PACKAGE has any dependencies, recursively activate them. +Return nil if the package could not be activated." + (let ((pkg-vec (cdr (assq package package-alist))) + available-version found) + ;; Check if PACKAGE is available in `package-alist'. + (when pkg-vec + (setq available-version (package-desc-vers pkg-vec) + found (version-list-<= version available-version))) + (cond + ;; If no such package is found, maybe it's built-in. + ((null found) + (package-built-in-p package version)) + ;; If the package is already activated, just return t. + ((memq package package-activated-list) + t) + ;; Otherwise, proceed with activation. + (t + (let ((fail (catch 'dep-failure + ;; Activate its dependencies recursively. + (dolist (req (package-desc-reqs pkg-vec)) + (unless (package-activate (car req) (cadr 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 package pkg-vec))))))) + +(defun package-mark-obsolete (package pkg-vec) + "Put package on the obsolete list, if not already there." + (let ((elt (assq package package-obsolete-alist))) + (if elt + ;; If this obsolete version does not exist in the list, update + ;; it the list. + (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) + (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) + (cdr elt)))) + ;; Make a new association. + (push (cons package (list (cons (package-desc-vers pkg-vec) + pkg-vec))) + package-obsolete-alist)))) + +(defun define-package (name-string version-string + &optional docstring requirements + &rest extra-properties) + "Define a new package. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a list of +integers of the form produced by `version-to-list'. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. +Each requirement is of the form (OTHER-PACKAGE \"VERSION\"). + +EXTRA-PROPERTIES is currently unused." + (let* ((name (intern name-string)) + (version (version-to-list version-string)) + (new-pkg-desc + (cons name + (vector version + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requirements) + docstring))) + (old-pkg (assq name package-alist))) + (cond + ;; If there's no old package, just add this to `package-alist'. + ((null old-pkg) + (push new-pkg-desc package-alist)) + ((version-list-< (package-desc-vers (cdr old-pkg)) version) + ;; Remove the old package and declare it obsolete. + (package-mark-obsolete name (cdr old-pkg)) + (setq package-alist (cons new-pkg-desc + (delq old-pkg package-alist)))) + ;; You can have two packages with the same version, e.g. one in + ;; the system package directory and one in your private + ;; directory. We just let the first one win. + ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) + ;; The package is born obsolete. + (package-mark-obsolete name (cdr new-pkg-desc)))))) + +;; From Emacs 22. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file)) + file) + +(defun package-generate-autoloads (name pkg-dir) + (let* ((auto-name (concat name "-autoloads.el")) + (ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (version-control 'never)) + (require 'autoload) + (unless (fboundp 'autoload-ensure-default-file) + (package-autoload-ensure-default-file generated-autoload-file)) + (update-directory-autoloads pkg-dir))) + +(defun package-untar-buffer () + "Untar the current buffer. +This uses `tar-untar-buffer' if it is available. +Otherwise it uses an external `tar' program. +`default-directory' should be set by the caller." + (require 'tar-mode) + (if (fboundp 'tar-untar-buffer) + (progn + ;; tar-mode messes with narrowing, so we just let it have the + ;; whole buffer to play with. + (delete-region (point-min) (point)) + (tar-mode) + (tar-untar-buffer)) + ;; FIXME: check the result. + (call-process-region (point) (point-max) "tar" nil '(nil nil) nil + "xf" "-"))) + +(defun package-unpack (name version) + (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) + package-user-dir))) + (make-directory package-user-dir t) + ;; FIXME: should we delete PKG-DIR if it exists? + (let* ((default-directory (file-name-as-directory package-user-dir))) + (package-untar-buffer) + (package-generate-autoloads (symbol-name name) pkg-dir) + (let ((load-path (cons pkg-dir load-path))) + (byte-recompile-directory pkg-dir 0 t))))) + +(defun package--write-file-no-coding (file-name excl) + (let ((buffer-file-coding-system 'no-conversion)) + (write-region (point-min) (point-max) file-name nil nil nil excl))) + +(defun package-unpack-single (file-name version desc requires) + "Install the contents of the current buffer as a package." + ;; Special case "package". + (if (string= file-name "package") + (package--write-file-no-coding + (expand-file-name (concat file-name ".el") package-user-dir) + nil) + (let* ((pkg-dir (expand-file-name (concat file-name "-" version) + package-user-dir)) + (el-file (expand-file-name (concat file-name ".el") pkg-dir)) + (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) + (make-directory pkg-dir t) + (package--write-file-no-coding el-file 'excl) + (let ((print-level nil) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (list 'define-package + file-name + version + desc + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + "\n") + nil + pkg-file + nil nil nil 'excl)) + (package-generate-autoloads file-name pkg-dir) + (let ((load-path (cons pkg-dir load-path))) + (byte-recompile-directory pkg-dir 0 t))))) + +(defun package-handle-response () + "Handle the response from the server. +Parse the HTTP response and throw if an error occurred. +The url package seems to require extra processing for this. +This should be called in a `save-excursion', in the download buffer. +It will move point to somewhere in the headers." + ;; We assume HTTP here. + (require 'url-http) + (let ((response (url-http-parse-response))) + (when (or (< response 200) (>= response 300)) + (display-buffer (current-buffer)) + (error "Error during download request:%s" + (buffer-substring-no-properties (point) (progn + (end-of-line) + (point))))))) + +(defun package-download-single (name version desc requires) + "Download and install a single-file package." + (let ((buffer (url-retrieve-synchronously + (concat (package-archive-url name) + (symbol-name name) "-" version ".el")))) + (with-current-buffer buffer + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + (package-unpack-single (symbol-name name) version desc requires) + (kill-buffer buffer)))) + +(defun package-download-tar (name version) + "Download and install a tar package." + (let ((tar-buffer (url-retrieve-synchronously + (concat (package-archive-url name) + (symbol-name name) "-" version ".tar")))) + (with-current-buffer tar-buffer + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (package-unpack name version) + (kill-buffer tar-buffer)))) + +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of VERSION or newer, is installed. +Built-in packages also qualify." + (let ((pkg-desc (assq package package-alist))) + (if pkg-desc + (version-list-<= min-version + (package-desc-vers (cdr pkg-desc))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) + +(defun package-compute-transaction (package-list requirements) + "Return a list of packages to be installed, including PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). + +REQUIREMENTS should be a list of additional requirements; each +element in this list should have the form (PACKAGE VERSION), +where PACKAGE is a package name and VERSION is the required +version of that package (as a list). + +This function recursively computes the requirements of the +packages in REQUIREMENTS, and returns a list of all the packages +that must be installed. Packages that are already installed are +not included in this list." + (dolist (elt requirements) + (let* ((next-pkg (car elt)) + (next-version (cadr elt))) + (unless (package-installed-p next-pkg next-version) + ;; A package is required, but not installed. It might also be + ;; blocked via `package-load-list'. + (let ((pkg-desc (assq next-pkg package-archive-contents)) + hold) + (when (setq hold (assq next-pkg package-load-list)) + (setq hold (cadr hold)) + (cond ((eq hold nil) + (error "Required package '%s' is disabled" + (symbol-name next-pkg))) + ((null (stringp hold)) + (error "Invalid element in `package-load-list'")) + ((version-list-< (version-to-list hold) next-version) + (error "Package `%s' held at version %s, \ +but version %s required" + (symbol-name next-pkg) hold + (package-version-join next-version))))) + (unless pkg-desc + (error "Package `%s-%s' is unavailable" + (symbol-name next-pkg) + (package-version-join next-version))) + (unless (version-list-<= next-version + (package-desc-vers (cdr pkg-desc))) + (error + "Need package `%s-%s', but only %s is available" + (symbol-name next-pkg) (package-version-join next-version) + (package-version-join (package-desc-vers (cdr pkg-desc))))) + ;; Only add to the transaction if we don't already have it. + (unless (memq next-pkg package-list) + (push next-pkg package-list)) + (setq package-list + (package-compute-transaction package-list + (package-desc-reqs + (cdr pkg-desc)))))))) + package-list) + +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((dir (concat "archives/" archive)) + (contents-file (concat dir "/archive-contents")) + contents) + (when (setq contents (package--read-archive-file contents-file)) + (dolist (package contents) + (package--add-to-archive-contents package archive))))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +Also, add the originating archive to the end of the package vector." + (let* ((name (car package)) + (version (aref (cdr package) 0)) + (entry (cons (car package) + (vconcat (cdr package) (vector archive)))) + (existing-package (cdr (assq name package-archive-contents)))) + (when (or (not existing-package) + (version-list-< (aref existing-package 0) version)) + (add-to-list 'package-archive-contents entry)))) + +(defun package-download-transaction (package-list) + "Download and install all the packages in PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). +This function assumes that all package requirements in +PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed +using `package-compute-transaction'." + (dolist (elt package-list) + (let* ((desc (cdr (assq elt package-archive-contents))) + ;; As an exception, if package is "held" in + ;; `package-load-list', download the held version. + (hold (cadr (assq elt package-load-list))) + (v-string (or (and (stringp hold) hold) + (package-version-join (package-desc-vers desc)))) + (kind (package-desc-kind desc))) + (cond + ((eq kind 'tar) + (package-download-tar elt v-string)) + ((eq kind 'single) + (package-download-single elt v-string + (package-desc-doc desc) + (package-desc-reqs desc))) + (t + (error "Unknown package kind: %s" (symbol-name kind))))))) + +;;;###autoload +(defun package-install (name) + "Install the package named NAME. +Interactively, prompt for the package name. +The package is found on one of the archives in `package-archives'." + (interactive + (list (intern (completing-read "Install package: " + (mapcar (lambda (elt) + (cons (symbol-name (car elt)) + nil)) + package-archive-contents) + nil t)))) + (let ((pkg-desc (assq name package-archive-contents))) + (unless pkg-desc + (error "Package `%s' is not available for installation" + (symbol-name name))) + (package-download-transaction + (package-compute-transaction (list name) + (package-desc-reqs (cdr pkg-desc))))) + ;; Try to activate it. + (package-initialize)) + +(defun package-strip-rcs-id (v-str) + "Strip RCS version ID from the version string. +If the result looks like a dotted numeric version, return it. +Otherwise return nil." + (if v-str + (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str) + (match-string 1 v-str) + (if (string-match "^[0-9.]*$" v-str) + v-str)))) + +(defun package-buffer-info () + "Return a vector describing the package in the current buffer. +The vector has the form + + [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] + +FILENAME is the file name, a string, sans the \".el\" extension. +REQUIRES is a requires list, or nil. +DESCRIPTION is the package description, a string. +VERSION is the version, a string. +COMMENTARY is the commentary section, a string, or nil if none. + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." + (goto-char (point-min)) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) + (error "Packages lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + (requires (if requires-str + (package-read-from-string requires-str))) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (commentary (lm-commentary))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + ;; Turn string version numbers into list form. + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requires)) + (vector file-name requires desc pkg-version commentary)))) + +(defun package-tar-file-info (file) + "Find package information for a tar file. +FILE is the name of the tar file to examine. +The return result is a vector like `package-buffer-info'." + (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) + (error "Invalid package name `%s'" file)) + (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) + (pkg-version (match-string-no-properties 2 file)) + ;; Extract the package descriptor. + (pkg-def-contents (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/" + pkg-name "-pkg.el"))) + (pkg-def-parsed (package-read-from-string pkg-def-contents))) + (unless (eq (car pkg-def-parsed) 'define-package) + (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) + (version-string (nth 2 pkg-def-parsed)) + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) + (readme (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/README")))) + (unless (equal pkg-version version-string) + (error "Package has inconsistent versions")) + (unless (equal pkg-name name-str) + (error "Package has inconsistent names")) + ;; Kind of a hack. + (if (string-match ": Not found in archive" readme) + (setq readme nil)) + ;; Turn string version numbers into list form. + (if (eq (car requires) 'quote) + (setq requires (car (cdr requires)))) + (setq requires + (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + requires)) + (vector pkg-name requires docstring version-string readme)))) + +;;;###autoload +(defun package-install-from-buffer (pkg-info type) + "Install a package from the current buffer. +When called interactively, the current buffer is assumed to be a +single .el file that follows the packaging guidelines; see info +node `(elisp)Packaging'. + +When called from Lisp, PKG-INFO is a vector describing the +information, of the type returned by `package-buffer-info'; and +TYPE is the package type (either `single' or `tar')." + (interactive (list (package-buffer-info) 'single)) + (save-excursion + (save-restriction + (let* ((file-name (aref pkg-info 0)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + "No description available." + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3))) + ;; Download and install the dependencies. + (let ((transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (cond + ((eq type 'single) + (package-unpack-single file-name pkg-version desc requires)) + ((eq type 'tar) + (package-unpack (intern file-name) pkg-version)) + (t + (error "Unknown type: %s" (symbol-name type)))) + ;; Try to activate it. + (package-initialize))))) + +;;;###autoload +(defun package-install-file (file) + "Install a package from a file. +The file can either be a tar file or an Emacs Lisp file." + (interactive "fPackage file name: ") + (with-temp-buffer + (insert-file-contents-literally file) + (cond + ((string-match "\\.el$" file) + (package-install-from-buffer (package-buffer-info) 'single)) + ((string-match "\\.tar$" file) + (package-install-from-buffer (package-tar-file-info file) 'tar)) + (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) + +(defun package-delete (name version) + (let ((dir (package--dir name version))) + (if (string-equal (file-name-directory dir) + (file-name-as-directory + (expand-file-name package-user-dir))) + (progn + (delete-directory dir t t) + (message "Package `%s-%s' deleted." name version)) + ;; Don't delete "system" packages + (error "Package `%s-%s' is a system package, not deleting" + name version)))) + +(defun package-archive-url (name) + "Return the archive containing the package NAME." + (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) + (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) + +(defun package--download-one-archive (archive file) + "Download an archive file FILE from ARCHIVE, and cache it locally." + (let* ((archive-name (car archive)) + (archive-url (cdr archive)) + (dir (expand-file-name "archives" package-user-dir)) + (dir (expand-file-name archive-name dir)) + (buffer (url-retrieve-synchronously (concat archive-url file)))) + (with-current-buffer buffer + (package-handle-response) + (re-search-forward "^$" nil 'move) + (forward-char) + (delete-region (point-min) (point)) + ;; Read the retrieved buffer to make sure it is valid (e.g. it + ;; may fetch a URL redirect page). + (when (listp (read buffer)) + (make-directory dir t) + (setq buffer-file-name (expand-file-name file dir)) + (let ((version-control 'never)) + (save-buffer)))) + (kill-buffer buffer))) + +(defun package-refresh-contents () + "Download the ELPA archive description if needed. +This informs Emacs about the latest versions of all packages, and +makes them available for download." + (interactive) + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (dolist (archive package-archives) + (condition-case nil + (package--download-one-archive archive "archive-contents") + (error (message "Failed to download `%s' archive." + (car archive))))) + (package-read-all-archive-contents)) + +(defvar package--initialized nil) + +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages." + (interactive) + (setq package-alist nil + package-obsolete-alist nil) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt) (package-desc-vers (cdr elt))))) + (setq package--initialized t)) + + +;;;; Package description buffer. + +;;;###autoload +(defun describe-package (package) + "Display the full documentation of PACKAGE (a symbol)." + (interactive + (let* ((guess (function-called-at-point)) + packages val) + (require 'finder-inf nil t) + ;; Load the package list if necessary (but don't activate them). + (unless package--initialized + (package-initialize t)) + (setq packages (append (mapcar 'car package-alist) + (mapcar 'car package-archive-contents) + (mapcar 'car package--builtins))) + (unless (memq guess packages) + (setq guess nil)) + (setq packages (mapcar 'symbol-name packages)) + (setq val + (completing-read (if guess + (format "Describe package (default %s): " + guess) + "Describe package: ") + packages nil t nil nil guess)) + (list (if (equal val "") guess (intern val))))) + (if (or (null package) (not (symbolp package))) + (message "No package specified") + (help-setup-xref (list #'describe-package package) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (describe-package-1 package))))) + +(defun describe-package-1 (package) + (require 'lisp-mnt) + (let ((package-name (symbol-name package)) + (built-in (assq package package--builtins)) + desc pkg-dir reqs version installable) + (prin1 package) + (princ " is ") + (cond + ;; Loaded packages are in `package-alist'. + ((setq desc (cdr (assq package package-alist))) + (setq version (package-version-join (package-desc-vers desc))) + (if (setq pkg-dir (package--dir package-name version)) + (insert "an installed package.\n\n") + ;; This normally does not happen. + (insert "a deleted package.\n\n"))) + ;; Available packages are in `package-archive-contents'. + ((setq desc (cdr (assq package package-archive-contents))) + (setq version (package-version-join (package-desc-vers desc)) + installable t) + (if built-in + (insert "a built-in package.\n\n") + (insert "an uninstalled package.\n\n"))) + (built-in + (setq desc (cdr built-in) + version (package-version-join (package-desc-vers desc))) + (insert "a built-in package.\n\n")) + (t + (insert "an orphan package.\n\n"))) + + (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") + (cond (pkg-dir + (insert (propertize "Installed" + 'font-lock-face 'font-lock-comment-face)) + (insert " in `") + ;; Todo: Add button for uninstalling. + (help-insert-xref-button (file-name-as-directory pkg-dir) + 'help-package-def pkg-dir) + (if built-in + (insert "',\n shadowing a " + (propertize "built-in package" + 'font-lock-face 'font-lock-builtin-face) + ".") + (insert "'."))) + (installable + (if built-in + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) + " Alternate version available -- ") + (insert "Available -- ")) + (let ((button-text (if (display-graphic-p) "Install" "[Install]")) + (button-face (if (display-graphic-p) + '(:box (:line-width 2 :color "dark grey") + :background "light grey" + :foreground "black") + 'link))) + (insert-text-button button-text 'face button-face 'follow-link t + 'package-symbol package + 'action 'package-install-button-action))) + (built-in + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) + (t (insert "Deleted."))) + (insert "\n") + (and version (> (length version) 0) + (insert " " + (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) + + (setq reqs (if desc (package-desc-reqs desc))) + (when reqs + (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") + (let ((first t) + name vers text) + (dolist (req reqs) + (setq name (car req) + vers (cadr req) + text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name)) + (insert "\n"))) + (insert " " (propertize "Summary" 'font-lock-face 'bold) + ": " (if desc (package-desc-doc desc)) "\n\n") + + (if built-in + ;; For built-in packages, insert the commentary. + (let ((fn (locate-file (concat package-name ".el") load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) + (let ((readme (expand-file-name (concat package-name "-readme.txt") + package-user-dir))) + ;; For elpa packages, try downloading the commentary. If that + ;; fails, try an existing readme file in `package-user-dir'. + (cond ((let ((buffer (ignore-errors + (url-retrieve-synchronously + (concat (package-archive-url package) + package-name "-readme.txt")))) + response) + (when buffer + (with-current-buffer buffer + (setq response (url-http-parse-response)) + (if (or (< response 200) (>= response 300)) + (setq response nil) + (setq buffer-file-name + (expand-file-name readme package-user-dir)) + (delete-region (point-min) (1+ url-http-end-of-headers)) + (save-buffer))) + (when response + (insert-buffer-substring buffer) + (kill-buffer buffer) + t)))) + ((file-readable-p readme) + (insert-file-contents readme) + (goto-char (point-max)))))))) + +(defun package-install-button-action (button) + (let ((package (button-get button 'package-symbol))) + (when (y-or-n-p (format "Install package `%s'? " package)) + (package-install package) + (revert-buffer nil t) + (goto-char (point-min))))) + + +;;;; Package menu mode. + +(defvar package-menu-mode-map + (let ((map (make-keymap)) + (menu-map (make-sparse-keymap "Package"))) + (set-keymap-parent map button-buffer-map) + (define-key map "\C-m" 'package-menu-describe-package) + (define-key map "q" 'quit-window) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) + (define-key map "u" 'package-menu-mark-unmark) + (define-key map "\177" 'package-menu-backup-unmark) + (define-key map "d" 'package-menu-mark-delete) + (define-key map "i" 'package-menu-mark-install) + (define-key map "g" 'revert-buffer) + (define-key map "r" 'package-menu-refresh) + (define-key map "~" 'package-menu-mark-obsolete-for-deletion) + (define-key map "x" 'package-menu-execute) + (define-key map "h" 'package-menu-quick-help) + (define-key map "?" 'package-menu-describe-package) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'mouse-select-window) + (define-key map [menu-bar package-menu] (cons "Package" menu-map)) + (define-key menu-map [mq] + '(menu-item "Quit" quit-window + :help "Quit package selection")) + (define-key menu-map [s1] '("--")) + (define-key menu-map [mn] + '(menu-item "Next" next-line + :help "Next Line")) + (define-key menu-map [mp] + '(menu-item "Previous" previous-line + :help "Previous Line")) + (define-key menu-map [s2] '("--")) + (define-key menu-map [mu] + '(menu-item "Unmark" package-menu-mark-unmark + :help "Clear any marks on a package and move to the next line")) + (define-key menu-map [munm] + '(menu-item "Unmark backwards" package-menu-backup-unmark + :help "Back up one line and clear any marks on that package")) + (define-key menu-map [md] + '(menu-item "Mark for deletion" package-menu-mark-delete + :help "Mark a package for deletion and move to the next line")) + (define-key menu-map [mi] + '(menu-item "Mark for install" package-menu-mark-install + :help "Mark a package for installation and move to the next line")) + (define-key menu-map [s3] '("--")) + (define-key menu-map [mg] + '(menu-item "Update package list" revert-buffer + :help "Update the list of packages")) + (define-key menu-map [mr] + '(menu-item "Refresh package list" package-menu-refresh + :help "Download the ELPA archive")) + (define-key menu-map [s4] '("--")) + (define-key menu-map [mt] + '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion + :help "Mark all obsolete packages for deletion")) + (define-key menu-map [mx] + '(menu-item "Execute actions" package-menu-execute + :help "Perform all the marked actions")) + (define-key menu-map [s5] '("--")) + (define-key menu-map [mh] + '(menu-item "Help" package-menu-quick-help + :help "Show short key binding help for package-menu-mode")) + (define-key menu-map [mc] + '(menu-item "View Commentary" package-menu-view-commentary + :help "Display information about this package")) + map) + "Local keymap for `package-menu-mode' buffers.") + +(defvar package-menu-sort-button-map + (let ((map (make-sparse-keymap))) + (define-key map [header-line mouse-1] 'package-menu-sort-by-column) + (define-key map [header-line mouse-2] 'package-menu-sort-by-column) + (define-key map [follow-link] 'mouse-face) + map) + "Local keymap for package menu sort buttons.") + +(put 'package-menu-mode 'mode-class 'special) + +(defun package-menu-mode () + "Major mode for browsing a list of packages. +Letters do not insert themselves; instead, they are commands. +\\<package-menu-mode-map> +\\{package-menu-mode-map}" + (kill-all-local-variables) + (use-local-map package-menu-mode-map) + (setq major-mode 'package-menu-mode) + (setq mode-name "Package Menu") + (setq truncate-lines t) + (setq buffer-read-only t) + (set (make-local-variable 'revert-buffer-function) 'package-menu-revert) + (setq header-line-format + (mapconcat + (lambda (pair) + (let ((column (car pair)) + (name (cdr pair))) + (concat + ;; Insert a space that aligns the button properly. + (propertize " " 'display (list 'space :align-to column) + 'face 'fixed-pitch) + ;; Set up the column button. + (propertize name + 'column-name name + 'help-echo "mouse-1: sort by column" + 'mouse-face 'highlight + 'keymap package-menu-sort-button-map)))) + ;; We take a trick from buff-menu and have a dummy leading + ;; space to align the header line with the beginning of the + ;; text. This doesn't really work properly on Emacs 21, but + ;; it is close enough. + '((0 . "") + (2 . "Package") + (20 . "Version") + (32 . "Status") + (43 . "Description")) + "")) + (run-mode-hooks 'package-menu-mode-hook)) + +(defun package-menu-refresh () + "Download the Emacs Lisp package archive. +This fetches the contents of each archive specified in +`package-archives', and then refreshes the package menu." + (interactive) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) + (package-refresh-contents) + (package--generate-package-list)) + +(defun package-menu-revert (&optional arg noconfirm) + "Update the list of packages. +This function is the `revert-buffer-function' for Package Menu +buffers. The arguments are ignored." + (interactive) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) + (package--generate-package-list)) + +(defun package-menu-describe-package () + "Describe the package in the current line." + (interactive) + (let ((name (package-menu-get-package))) + (if name + (describe-package (intern name)) + (message "No package on this line")))) + +(defun package-menu-mark-internal (what) + (unless (eobp) + (let ((buffer-read-only nil)) + (beginning-of-line) + (delete-char 1) + (insert what) + (forward-line)))) + +;; fixme numeric argument +(defun package-menu-mark-delete (num) + "Mark a package for deletion and move to the next line." + (interactive "p") + (if (string-equal (package-menu-get-status) "installed") + (package-menu-mark-internal "D") + (forward-line))) + +(defun package-menu-mark-install (num) + "Mark a package for installation and move to the next line." + (interactive "p") + (if (string-equal (package-menu-get-status) "available") + (package-menu-mark-internal "I") + (forward-line))) + +(defun package-menu-mark-unmark (num) + "Clear any marks on a package and move to the next line." + (interactive "p") + (package-menu-mark-internal " ")) + +(defun package-menu-backup-unmark () + "Back up one line and clear any marks on that package." + (interactive) + (forward-line -1) + (package-menu-mark-internal " ") + (forward-line -1)) + +(defun package-menu-mark-obsolete-for-deletion () + "Mark all obsolete packages for deletion." + (interactive) + (save-excursion + (goto-char (point-min)) + (forward-line 2) + (while (not (eobp)) + (if (looking-at ".*\\s obsolete\\s ") + (package-menu-mark-internal "D") + (forward-line 1))))) + +(defun package-menu-quick-help () + "Show short key binding help for package-menu-mode." + (interactive) + (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) + +(define-obsolete-function-alias + 'package-menu-view-commentary 'package-menu-describe-package "24.1") + +;; Return the name of the package on the current line. +(defun package-menu-get-package () + (save-excursion + (beginning-of-line) + (if (looking-at ". \\([^ \t]*\\)") + (match-string-no-properties 1)))) + +;; Return the version of the package on the current line. +(defun package-menu-get-version () + (save-excursion + (beginning-of-line) + (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)") + (match-string 1)))) + +(defun package-menu-get-status () + (save-excursion + (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)") + (match-string 1) + ""))) + +(defun package-menu-execute () + "Perform marked Package Menu actions. +Packages marked for installation are downloaded and installed; +packages marked for deletion are removed." + (interactive) + (let (install-list delete-list cmd) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq cmd (char-after)) + (cond + ((eq cmd ?\s) t) + ((eq cmd ?D) + (push (cons (package-menu-get-package) + (package-menu-get-version)) + delete-list)) + ((eq cmd ?I) + (push (package-menu-get-package) install-list))) + (forward-line))) + ;; Delete packages, prompting if necessary. + (when delete-list + (if (yes-or-no-p + (if (= (length delete-list) 1) + (format "Delete package `%s-%s'? " + (caar delete-list) + (cdr (car delete-list))) + (format "Delete these %d packages (%s)? " + (length delete-list) + (mapconcat (lambda (elt) + (concat (car elt) "-" (cdr elt))) + delete-list + ", ")))) + (dolist (elt delete-list) + (condition-case err + (package-delete (car elt) (cdr elt)) + (error (message (cadr err))))) + (error "Aborted"))) + (when install-list + (if (yes-or-no-p + (if (= (length install-list) 1) + (format "Install package `%s'? " (car install-list)) + (format "Install these %d packages (%s)? " + (length install-list) + (mapconcat 'identity install-list ", ")))) + (dolist (elt install-list) + (package-install (intern elt))))) + ;; If we deleted anything, regenerate `package-alist'. This is done + ;; automatically if we installed a package. + (and delete-list (null install-list) + (package-initialize)) + (if (or delete-list install-list) + (package-menu-revert) + (message "No operations specified.")))) + +(defun package-print-package (package version key desc) + (let ((face + (cond ((string= key "built-in") 'font-lock-builtin-face) + ((string= key "available") 'default) + ((string= key "held") 'font-lock-constant-face) + ((string= key "disabled") 'font-lock-warning-face) + ((string= key "installed") 'font-lock-comment-face) + (t ; obsolete, but also the default. + 'font-lock-warning-face)))) + (insert (propertize " " 'font-lock-face face)) + (insert-text-button (symbol-name package) + 'face 'link + 'follow-link t + 'package-symbol package + 'action (lambda (button) + (describe-package + (button-get button 'package-symbol)))) + (indent-to 20 1) + (insert (propertize (package-version-join version) 'font-lock-face face)) + (indent-to 32 1) + (insert (propertize key 'font-lock-face face)) + ;; FIXME: this 'when' is bogus... + (when desc + (indent-to 43 1) + (let ((opoint (point))) + (insert (propertize desc 'font-lock-face face)) + (upcase-region opoint (min (point) (1+ opoint))))) + (insert "\n"))) + +(defun package-list-maybe-add (package version status description result) + (unless (assoc (cons package version) result) + (push (list (cons package version) status description) result)) + result) + +(defvar package-menu-package-list nil + "List of packages to display in the Package Menu buffer. +A value of nil means to display all packages.") + +(defvar package-menu-sort-key nil + "Sort key for the current Package Menu buffer.") + +(defun package--generate-package-list () + "Populate the current Package Menu buffer." + (let ((inhibit-read-only t) + info-list name desc hold builtin) + (erase-buffer) + ;; List installed packages + (dolist (elt package-alist) + (setq name (car elt)) + (when (or (null package-menu-package-list) + (memq name package-menu-package-list)) + (setq desc (cdr elt) + hold (cadr (assq name package-load-list))) + (setq info-list + (package-list-maybe-add + name (package-desc-vers desc) + ;; FIXME: it turns out to be tricky to see if this + ;; package is presently activated. + (if (stringp hold) "held" "installed") + (package-desc-doc desc) + info-list)))) + + ;; List built-in packages + (dolist (elt package--builtins) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or (null package-menu-package-list) + (memq name package-menu-package-list))) + (setq desc (cdr elt)) + (setq info-list + (package-list-maybe-add + name (package-desc-vers desc) + "built-in" + (package-desc-doc desc) + info-list)))) + + ;; List available and disabled packages + (dolist (elt package-archive-contents) + (setq name (car elt) + desc (cdr elt) + hold (assq name package-load-list)) + (when (or (null package-menu-package-list) + (memq name package-menu-package-list)) + (setq info-list + (package-list-maybe-add name + (package-desc-vers desc) + (if (and hold (null (cadr hold))) + "disabled" + "available") + (package-desc-doc (cdr elt)) + info-list)))) + ;; List obsolete packages + (mapc (lambda (elt) + (mapc (lambda (inner-elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers + (cdr inner-elt)) + "obsolete" + (package-desc-doc + (cdr inner-elt)) + info-list))) + (cdr elt))) + package-obsolete-alist) + + (setq info-list + (sort info-list + (cond ((string= package-menu-sort-key "Package") + 'package-menu--name-predicate) + ((string= package-menu-sort-key "Version") + 'package-menu--version-predicate) + ((string= package-menu-sort-key "Description") + 'package-menu--description-predicate) + (t ; By default, sort by package status + 'package-menu--status-predicate)))) + + (dolist (elt info-list) + (package-print-package (car (car elt)) + (cdr (car elt)) + (car (cdr elt)) + (car (cdr (cdr elt))))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (current-buffer))) + +(defun package-menu--version-predicate (left right) + (let ((vleft (or (cdr (car left)) '(0))) + (vright (or (cdr (car right)) '(0)))) + (if (version-list-= vleft vright) + (package-menu--name-predicate left right) + (version-list-< vleft vright)))) + +(defun package-menu--status-predicate (left right) + (let ((sleft (cadr left)) + (sright (cadr right))) + (cond ((string= sleft sright) + (package-menu--name-predicate left right)) + ((string= sleft "available") t) + ((string= sright "available") nil) + ((string= sleft "installed") t) + ((string= sright "installed") nil) + ((string= sleft "held") t) + ((string= sright "held") nil) + ((string= sleft "built-in") t) + ((string= sright "built-in") nil) + ((string= sleft "obsolete") t) + ((string= sright "obsolete") nil) + (t (string< sleft sright))))) + +(defun package-menu--description-predicate (left right) + (let ((sleft (car (cddr left))) + (sright (car (cddr right)))) + (if (string= sleft sright) + (package-menu--name-predicate left right) + (string< sleft sright)))) + +(defun package-menu--name-predicate (left right) + (string< (symbol-name (caar left)) + (symbol-name (caar right)))) + +(defun package-menu-sort-by-column (&optional e) + "Sort the package menu by the column of the mouse click E." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos)) + (col (if obj + (get-text-property (cdr obj) 'column-name (car obj)) + (get-text-property (posn-point pos) 'column-name))) + (buf (window-buffer (posn-window (event-start e))))) + (with-current-buffer buf + (when (eq major-mode 'package-menu-mode) + (setq package-menu-sort-key col) + (package--generate-package-list))))) + +(defun package--list-packages (&optional packages) + "Generate and pop to the *Packages* buffer. +Optional PACKAGES is a list of names of packages (symbols) to +list; the default is to display everything in `package-alist'." + (require 'finder-inf nil t) + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (set (make-local-variable 'package-menu-package-list) packages) + (set (make-local-variable 'package-menu-sort-key) nil) + (package--generate-package-list)) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) + +;;;###autoload +(defun list-packages () + "Display a list of packages. +Fetches the updated list of packages before displaying. +The list is displayed in a buffer named `*Packages*'." + (interactive) + ;; Initialize the package system if necessary. + (unless package--initialized + (package-initialize t)) + (package-refresh-contents) + (package--list-packages)) + +;;;###autoload +(defalias 'package-list-packages 'list-packages) + +(defun package-list-packages-no-fetch () + "Display a list of packages. +Does not fetch the updated list of packages before displaying. +The list is displayed in a buffer named `*Packages*'." + (interactive) + (package--list-packages)) + +(provide 'package) + +;;; package.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el new file mode 100644 index 00000000000..24ea0a3e801 --- /dev/null +++ b/lisp/emacs-lisp/pcase.el @@ -0,0 +1,553 @@ +;;; pcase.el --- ML-style pattern-matching macro for Elisp + +;; Copyright (C) 2010-2011 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: + +;; ML-style pattern matching. +;; The entry points are autoloaded. + +;; Todo: + +;; - provide ways to extend the set of primitives, with some kind of +;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) +;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). +;; But better would be if we could define new ways to match by having the +;; extension provide its own `pcase--split-<foo>' thingy. +;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to +;; generate a lex-style DFA to decide whether to run E1 or E2. + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; Macro-expansion of pcase is reasonably fast, so it's not a problem +;; when byte-compiling a file, but when interpreting the code, if the pcase +;; is in a loop, the repeated macro-expansion becomes terribly costly, so we +;; memoize previous macro expansions to try and avoid recomputing them +;; over and over again. +(defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) + +(defconst pcase--dontcare-upats '(t _ dontcare)) + +;;;###autoload +(defmacro pcase (exp &rest cases) + "Perform ML-style pattern matching on EXP. +CASES is a list of elements of the form (UPATTERN CODE...). + +UPatterns can take the following forms: + _ matches anything. + SYMBOL matches anything and binds it to SYMBOL. + (or UPAT...) matches if any of the patterns matches. + (and UPAT...) matches if all the patterns match. + `QPAT matches if the QPattern QPAT matches. + (pred PRED) matches if PRED applied to the object returns non-nil. + (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. + +QPatterns can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + ,UPAT matches if the UPattern UPAT matches. + STRING matches if the object is `equal' to STRING. + ATOM matches if the object is `eq' to ATOM. +QPatterns for vectors are not implemented yet. + +PRED can take the form + FUNCTION in which case it gets called with one argument. + (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments. +A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). +PRED patterns can refer to variables bound earlier in the pattern. +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))))" + (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. + (or (gethash (cons exp cases) pcase-memoize) + (puthash (cons exp cases) + (pcase--expand exp cases) + pcase-memoize))) + +;;;###autoload +(defmacro pcase-let* (bindings &rest body) + "Like `let*' but where you can use `pcase' patterns for bindings. +BODY should be an expression, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (declare (indent 1) (debug let)) + (cond + ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body))) + ((pcase--trivial-upat-p (caar bindings)) + `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body))) + (t + `(pcase ,(cadr (car bindings)) + (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body)) + ;; We can either signal an error here, or just use `dontcare' which + ;; generates more efficient code. In practice, if we use `dontcare' we + ;; will still often get an error and the few cases where we don't do not + ;; matter that much, so it's a better choice. + (dontcare nil))))) + +;;;###autoload +(defmacro pcase-let (bindings &rest body) + "Like `let' but where you can use `pcase' patterns for bindings. +BODY should be a list of expressions, and BINDINGS should be a list of bindings +of the form (UPAT EXP)." + (declare (indent 1) (debug let)) + (if (null (cdr bindings)) + `(pcase-let* ,bindings ,@body) + (let ((matches '())) + (dolist (binding (prog1 bindings (setq bindings nil))) + (cond + ((memq (car binding) pcase--dontcare-upats) + (push (cons (make-symbol "_") (cdr binding)) bindings)) + ((pcase--trivial-upat-p (car binding)) (push binding bindings)) + (t + (let ((tmpvar (make-symbol (format "x%d" (length bindings))))) + (push (cons tmpvar (cdr binding)) bindings) + (push (list (car binding) tmpvar) matches))))) + `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) + +(defmacro pcase-dolist (spec &rest body) + (if (pcase--trivial-upat-p (car spec)) + `(dolist ,spec ,@body) + (let ((tmpvar (make-symbol "x"))) + `(dolist (,tmpvar ,@(cdr spec)) + (pcase-let* ((,(car spec) ,tmpvar)) + ,@body))))) + + +(defun pcase--trivial-upat-p (upat) + (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) + +(defun pcase--expand (exp cases) + (let* ((defs (if (symbolp exp) '() + (let ((sym (make-symbol "x"))) + (prog1 `((,sym ,exp)) (setq exp sym))))) + (seen '()) + (codegen + (lambda (code vars) + (let ((prev (assq code seen))) + (if (not prev) + (let ((res (pcase-codegen code vars))) + (push (list code vars res) seen) + res) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + ;; + ;; We've already used this branch. So it is shared. + (destructuring-bind (code prevvars res) prev + (unless (symbolp res) + ;; This is the first repeat, so we have to move + ;; the branch to a separate function. + (let ((bsym + (make-symbol (format "pcase-%d" (length defs))))) + (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs) + (setcar res 'funcall) + (setcdr res (cons bsym (mapcar #'cdr prevvars))) + (setcar (cddr prev) bsym) + (setq res bsym))) + (setq vars (copy-sequence vars)) + (let ((args (mapcar (lambda (pa) + (let ((v (assq (car pa) vars))) + (setq vars (delq v vars)) + (cdr v))) + prevvars))) + (when vars ;New additional vars. + (error "The vars %s are only bound in some paths" + (mapcar #'car vars))) + `(funcall ,res ,@args))))))) + (main + (pcase--u + (mapcar (lambda (case) + `((match ,exp . ,(car case)) + ,(apply-partially + (if (pcase--small-branch-p (cdr case)) + ;; Don't bother sharing multiple + ;; occurrences of this leaf since it's small. + #'pcase-codegen codegen) + (cdr case)))) + cases)))) + (if (null defs) main + `(let ,defs ,main)))) + +(defun pcase-codegen (code vars) + `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + ,@code)) + +(defun pcase--small-branch-p (code) + (and (= 1 (length code)) + (or (not (consp (car code))) + (let ((small t)) + (dolist (e (car code)) + (if (consp e) (setq small nil))) + small)))) + +;; Try to use `cond' rather than a sequence of `if's, so as to reduce +;; the depth of the generated tree. +(defun pcase--if (test then else) + (cond + ((eq else :pcase--dontcare) then) + ((eq (car-safe else) 'if) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + ;; FIXME: ideally, this should never happen because the pcase--split-* + ;; funs should have eliminated such things, but pcase--split-member + ;; is imprecise, so in practice it can happen occasionally. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) + (t `(if ,test ,then ,else)))) + +(defun pcase--upat (qpattern) + (cond + ((eq (car-safe qpattern) '\,) (cadr qpattern)) + (t (list '\` qpattern)))) + +;; Note about MATCH: +;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' +;; check, we want to turn all the similar patterns into ones of the form +;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction. +;; Earlier code hence used branches of the form (MATCHES . CODE) where +;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT). +;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is +;; no easy way to eliminate the `consp' check in such a representation. +;; So we replaced the MATCHES by the MATCH below which can be made up +;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can +;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into +;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)). +;; The downside is that we now have `or' and `and' both in MATCH and +;; in PAT, so there are different equivalent representations and we +;; need to handle them all. We do not try to systematically +;; canonicalize them to one form over another, but we do occasionally +;; turn one into the other. + +(defun pcase--u (branches) + "Expand matcher for rules BRANCHES. +Each BRANCH has the form (MATCH CODE . VARS) where +CODE is the code generator for that branch. +VARS is the set of vars already bound by earlier matches. +MATCH is the pattern that needs to be matched, of the form: + (match VAR . UPAT) + (and MATCH ...) + (or MATCH ...)" + (when (setq branches (delq nil branches)) + (destructuring-bind (match code &rest vars) (car branches) + (pcase--u1 (list match) code vars (cdr branches))))) + +(defun pcase--and (match matches) + (if matches `(and ,match ,@matches) match)) + +(defun pcase--split-match (sym splitter match) + (case (car match) + ((match) + (if (not (eq sym (cadr match))) + (cons match match) + (let ((pat (cddr match))) + (cond + ;; Hoist `or' and `and' patterns to `or' and `and' matches. + ((memq (car-safe pat) '(or and)) + (pcase--split-match sym splitter + (cons (car pat) + (mapcar (lambda (alt) + `(match ,sym . ,alt)) + (cdr pat))))) + (t (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match)))))))) + ((or and) + (let ((then-alts '()) + (else-alts '()) + (neutral-elem (if (eq 'or (car match)) + :pcase--fail :pcase--succeed)) + (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail))) + (dolist (alt (cdr match)) + (let ((split (pcase--split-match sym splitter alt))) + (unless (eq (car split) neutral-elem) + (push (car split) then-alts)) + (unless (eq (cdr split) neutral-elem) + (push (cdr split) else-alts)))) + (cons (cond ((memq zero-elem then-alts) zero-elem) + ((null then-alts) neutral-elem) + ((null (cdr then-alts)) (car then-alts)) + (t (cons (car match) (nreverse then-alts)))) + (cond ((memq zero-elem else-alts) zero-elem) + ((null else-alts) neutral-elem) + ((null (cdr else-alts)) (car else-alts)) + (t (cons (car match) (nreverse else-alts))))))) + (t (error "Uknown MATCH %s" match)))) + +(defun pcase--split-rest (sym splitter rest) + (let ((then-rest '()) + (else-rest '())) + (dolist (branch rest) + (let* ((match (car branch)) + (code&vars (cdr branch)) + (splitted + (pcase--split-match sym splitter match))) + (unless (eq (car splitted) :pcase--fail) + (push (cons (car splitted) code&vars) then-rest)) + (unless (eq (cdr splitted) :pcase--fail) + (push (cons (cdr splitted) code&vars) else-rest)))) + (cons (nreverse then-rest) (nreverse else-rest)))) + +(defun pcase--split-consp (syma symd pat) + (cond + ;; A QPattern for a cons, can only go the `then' side. + ((and (eq (car-safe pat) '\`) (consp (cadr pat))) + (let ((qpat (cadr pat))) + (cons `(and (match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat)))) + :pcase--fail))) + ;; A QPattern but not for a cons, can only go the `else' side. + ((eq (car-safe pat) '\`) (cons :pcase--fail nil)))) + +(defun pcase--split-equal (elem pat) + (cond + ;; The same match will give the same result. + ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) + (cons :pcase--succeed :pcase--fail)) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase--fail nil)))) + +(defun pcase--split-member (elems pat) + ;; Based on pcase--split-equal. + (cond + ;; The same match (or a match of membership in a superset) will + ;; give the same result, but we don't know how to check it. + ;; (??? + ;; (cons :pcase--succeed nil)) + ;; A match for one of the elements may succeed or fail. + ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) + nil) + ;; A different match will fail if this one succeeds. + ((and (eq (car-safe pat) '\`) + ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) + ;; (consp (cadr pat))) + ) + (cons :pcase--fail nil)))) + +(defun pcase--split-pred (upat pat) + ;; FIXME: For predicates like (pred (> a)), two such predicates may + ;; actually refer to different variables `a'. + (if (equal upat pat) + (cons :pcase--succeed :pcase--fail))) + +(defun pcase--fgrep (vars sexp) + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (pcase--fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + +;; It's very tempting to use `pcase' below, tho obviously, it'd create +;; bootstrapping problems. +(defun pcase--u1 (matches code vars rest) + "Return code that runs CODE (with VARS) if MATCHES match. +and otherwise defers to REST which is a list of branches of the form +\(ELSE-MATCH ELSE-CODE . ELSE-VARS)." + ;; Depending on the order in which we choose to check each of the MATCHES, + ;; the resulting tree may be smaller or bigger. So in general, we'd want + ;; to be careful to chose the "optimal" order. But predicate + ;; patterns make this harder because they create dependencies + ;; between matches. So we don't bother trying to reorder anything. + (cond + ((null matches) (funcall code vars)) + ((eq :pcase--fail (car matches)) (pcase--u rest)) + ((eq :pcase--succeed (car matches)) + (pcase--u1 (cdr matches) code vars rest)) + ((eq 'and (caar matches)) + (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest)) + ((eq 'or (caar matches)) + (let* ((alts (cdar matches)) + (var (if (eq (caar alts) 'match) (cadr (car alts)))) + (simples '()) (others '())) + (when var + (dolist (alt alts) + (if (and (eq (car alt) 'match) (eq var (cadr alt)) + (let ((upat (cddr alt))) + (and (eq (car-safe upat) '\`) + (or (integerp (cadr upat)) (symbolp (cadr upat)) + (stringp (cadr upat)))))) + (push (cddr alt) simples) + (push alt others)))) + (cond + ((null alts) (error "Please avoid it") (pcase--u rest)) + ((> (length simples) 1) + ;; De-hoist the `or' MATCH into an `or' pattern that will be + ;; turned into a `memq' below. + (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + code vars + (if (null others) rest + (cons (list* + (pcase--and (if (cdr others) + (cons 'or (nreverse others)) + (car others)) + (cdr matches)) + code vars) + rest)))) + (t + (pcase--u1 (cons (pop alts) (cdr matches)) code vars + (if (null alts) (progn (error "Please avoid it") rest) + (cons (list* + (pcase--and (if (cdr alts) + (cons 'or alts) (car alts)) + (cdr matches)) + code vars) + rest))))))) + ((eq 'match (caar matches)) + (destructuring-bind (op sym &rest upat) (pop matches) + (cond + ((memq upat '(t _)) (pcase--u1 matches code vars rest)) + ((eq upat 'dontcare) :pcase--dontcare) + ((functionp upat) (error "Feature removed, use (pred %s)" upat)) + ((memq (car-safe upat) '(guard pred)) + (destructuring-bind (then-rest &rest else-rest) + (pcase--split-rest + sym (apply-partially #'pcase--split-pred upat) rest) + (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) + `(,(cadr upat) ,sym) + (let* ((exp (cadr upat)) + ;; `vs' is an upper bound on the vars we need. + (vs (pcase--fgrep (mapcar #'car vars) exp)) + (call (cond + ((eq 'guard (car upat)) exp) + ((functionp exp) `(,exp ,sym)) + (t `(,@exp ,sym))))) + (if (null vs) + call + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let ,(mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs) + ;; FIXME: `vars' can capture `sym'. E.g. + ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) + ,call)))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + ((symbolp upat) + (pcase--u1 matches code (cons (cons upat sym) vars) rest)) + ((eq (car-safe upat) '\`) + (pcase--q1 sym (cadr upat) matches code vars rest)) + ((eq (car-safe upat) 'or) + (let ((all (> (length (cdr upat)) 1)) + (memq-fine t)) + (when all + (dolist (alt (cdr upat)) + (unless (and (eq (car-safe alt) '\`) + (or (symbolp (cadr alt)) (integerp (cadr alt)) + (setq memq-fine nil) + (stringp (cadr alt)))) + (setq all nil)))) + (if all + ;; Use memq for (or `a `b `c `d) rather than a big tree. + (let ((elems (mapcar 'cadr (cdr upat)))) + (destructuring-bind (then-rest &rest else-rest) + (pcase--split-rest + sym (apply-partially #'pcase--split-member elems) rest) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars + (append (mapcar (lambda (upat) + `((and (match ,sym . ,upat) ,@matches) + ,code ,@vars)) + (cddr upat)) + rest))))) + ((eq (car-safe upat) 'and) + (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) + (cdr upat)) + matches) + code vars rest)) + ((eq (car-safe upat) 'not) + ;; FIXME: The implementation below is naive and results in + ;; inefficient code. + ;; To make it work right, we would need to turn pcase--u1's + ;; `code' and `vars' into a single argument of the same form as + ;; `rest'. We would also need to split this new `then-rest' argument + ;; for every test (currently we don't bother to do it since + ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) + ;; `(PAT3 . PAT4)) which the programmer can easily rewrite + ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). + (pcase--u1 `((match ,sym . ,(cadr upat))) + (lexical-let ((rest rest)) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest))) + vars + (list `((and . ,matches) ,code . ,vars)))) + (t (error "Unknown upattern `%s'" upat))))) + (t (error "Incorrect MATCH %s" (car matches))))) + +(defun pcase--q1 (sym qpat matches code vars rest) + "Return code that runs CODE if SYM matches QPAT and if MATCHES match. +and if not, defers to REST which is a list of branches of the form +\(OTHER_MATCH OTHER-CODE . OTHER-VARS)." + (cond + ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) + ((floatp qpat) (error "Floating point patterns not supported")) + ((vectorp qpat) + ;; FIXME. + (error "Vector QPatterns not implemented yet")) + ((consp qpat) + (let ((syma (make-symbol "xcar")) + (symd (make-symbol "xcdr"))) + (destructuring-bind (then-rest &rest else-rest) + (pcase--split-rest sym + (apply-partially #'pcase--split-consp syma symd) + rest) + (pcase--if `(consp ,sym) + `(let ((,syma (car ,sym)) + (,symd (cdr ,sym))) + ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat))) + ,@matches) + code vars then-rest)) + (pcase--u else-rest))))) + ((or (integerp qpat) (symbolp qpat) (stringp qpat)) + (destructuring-bind (then-rest &rest else-rest) + (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) + (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) + (t (error "Unkown QPattern %s" qpat)))) + + +(provide 'pcase) +;;; pcase.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 34ac4f95d59..2d1b8860a3c 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,7 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp @@ -202,5 +201,4 @@ Ignores leading comment characters." (provide 'pp) ; so (require 'pp) works -;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9 ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index fd47c576404..e3c030b3c60 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -1,7 +1,6 @@ ;;; re-builder.el --- building Regexps with visual feedback -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1999-2011 Free Software Foundation, Inc. ;; Author: Detlev Zundel <dzu@gnu.org> ;; Keywords: matching, lisp, tools @@ -60,15 +59,13 @@ ;; even the auto updates go all the way. Forcing an update overrides ;; this limit allowing an easy way to see all matches. -;; Currently `re-builder' understands five different forms of input, -;; namely `read', `string', `rx', `sregex' and `lisp-re' syntax. Read +;; Currently `re-builder' understands three different forms of input, +;; namely `read', `string', and `rx' syntax. Read ;; syntax and string syntax are both delimited by `"'s and behave ;; according to their name. With the `string' syntax there's no need ;; to escape the backslashes and double quotes simplifying the editing ;; somewhat. The other three allow editing of symbolic regular -;; expressions supported by the packages of the same name. (`lisp-re' -;; is a package by me and its support may go away as it is nearly the -;; same as the `sregex' package in Emacs) +;; expressions supported by the packages of the same name. ;; Editing symbolic expressions is done through a major mode derived ;; from `emacs-lisp-mode' so you'll get all the good stuff like @@ -77,7 +74,7 @@ ;; When editing a symbolic regular expression, only the first ;; expression in the RE Builder buffer is considered, which helps ;; limiting the extent of the expression like the `"'s do for the text -;; modes. For the `sregex' syntax the function `sregex' is applied to +;; modes. For the `rx' syntax the function `rx-to-string' is applied to ;; the evaluated expression read. So you can use quoted arguments ;; with something like '("findme") or you can construct arguments to ;; your hearts delight with a valid ELisp expression. (The compiled @@ -128,12 +125,10 @@ (defcustom reb-re-syntax 'read "Syntax for the REs in the RE Builder. -Can either be `read', `string', `sregex', `lisp-re', `rx'." +Can either be `read', `string', or `rx'." :group 're-builder :type '(choice (const :tag "Read syntax" read) (const :tag "String syntax" string) - (const :tag "`sregex' syntax" sregex) - (const :tag "`lisp-re' syntax" lisp-re) (const :tag "`rx' syntax" rx))) (defcustom reb-auto-match-limit 200 @@ -283,12 +278,9 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-derived-mode reb-lisp-mode emacs-lisp-mode "RE Builder Lisp" "Major mode for interactively building symbolic Regular Expressions." - (cond ((eq reb-re-syntax 'lisp-re) ; Pull in packages - (require 'lisp-re)) ; as needed - ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded - (require 'sregex)) ; right now.. - ((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded - (require 'rx))) ; require rx anyway + ;; Pull in packages as needed + (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded + (require 'rx))) ; require rx anyway (reb-mode-common)) ;; Use the same "\C-c" keymap as `reb-mode' and use font-locking from @@ -331,7 +323,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (defsubst reb-lisp-syntax-p () "Return non-nil if RE Builder uses a Lisp syntax." - (memq reb-re-syntax '(lisp-re sregex rx))) + (memq reb-re-syntax '(sregex rx))) (defmacro reb-target-binding (symbol) "Return binding for SYMBOL in the RE Builder target buffer." @@ -491,10 +483,10 @@ Optional argument SYNTAX must be specified if called non-interactively." (list (intern (completing-read "Select syntax: " (mapcar (lambda (el) (cons (symbol-name el) 1)) - '(read string lisp-re sregex rx)) + '(read string sregex rx)) nil t (symbol-name reb-re-syntax))))) - (if (memq syntax '(read string lisp-re sregex rx)) + (if (memq syntax '(read string sregex rx)) (let ((buffer (get-buffer reb-buffer))) (setq reb-re-syntax syntax) (when buffer @@ -618,12 +610,7 @@ optional fourth argument FORCE is non-nil." (defun reb-cook-regexp (re) "Return RE after processing it according to `reb-re-syntax'." - (cond ((eq reb-re-syntax 'lisp-re) - (when (fboundp 'lre-compile-string) - (lre-compile-string (eval (car (read-from-string re)))))) - ((eq reb-re-syntax 'sregex) - (apply 'sregex (eval (car (read-from-string re))))) - ((eq reb-re-syntax 'rx) + (cond ((memq reb-re-syntax '(sregex rx)) (rx-to-string (eval (car (read-from-string re))))) (t re))) @@ -727,5 +714,4 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (provide 're-builder) -;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7 ;;; re-builder.el ends here diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 512f86b24d0..b538a7a2943 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -1,7 +1,6 @@ ;;; regexp-opt.el --- generate efficient regexps to match strings -;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1994-2011 Free Software Foundation, Inc. ;; Author: Simon Marshall <simon@gnu.org> ;; Maintainer: FSF @@ -96,19 +95,24 @@ The returned regexp is typically more efficient than the equivalent regexp: (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) If PAREN is `words', then the resulting regexp is additionally surrounded -by \\=\\< and \\>." +by \\=\\< and \\>. +If PAREN is `symbols', then the resulting regexp is additionally surrounded +by \\=\\_< and \\_>." (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) (max-specpdl-size 10000) (completion-ignore-case nil) (completion-regexp-list nil) - (words (eq paren 'words)) (open (cond ((stringp paren) paren) (paren "\\("))) (sorted-strings (delete-dups (sort (copy-sequence strings) 'string-lessp))) (re (regexp-opt-group sorted-strings (or open t) (not open)))) - (if words (concat "\\<" re "\\>") re)))) + (cond ((eq paren 'words) + (concat "\\<" re "\\>")) + ((eq paren 'symbols) + (concat "\\_<" re "\\_>")) + (t re))))) ;;;###autoload (defun regexp-opt-depth (regexp) @@ -120,7 +124,7 @@ This means the number of non-shy regexp grouping constructs (string-match regexp "") ;; Count the number of open parentheses in REGEXP. (let ((count 0) start last) - (while (string-match "\\\\(\\(\\?:\\)?" regexp start) + (while (string-match "\\\\(\\(\\?[0-9]*:\\)?" regexp start) (setq start (match-end 0)) ; Start of next search. (when (and (not (match-beginning 1)) (subregexp-context-p regexp (match-beginning 0) last)) @@ -288,5 +292,4 @@ Merges keywords to avoid backtracking in Emacs' regexp matcher." (provide 'regexp-opt) -;; arch-tag: 6c5a66f4-29af-4fd6-8c3b-4b554d5b4370 ;;; regexp-opt.el ends here diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 53cf21b2f99..8000dcd53dd 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,7 +1,6 @@ ;;; regi.el --- REGular expression Interpreting engine -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> ;; Maintainer: bwarsaw@cen.com @@ -254,5 +253,4 @@ useful information: (provide 'regi) -;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747 ;;; regi.el ends here diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 91ea5a93aab..affaa9ce32e 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -1,7 +1,6 @@ ;;; ring.el --- handle rings of items -;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2001-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: extensions @@ -236,5 +235,4 @@ If SEQ is already a ring, return it." (provide 'ring) -;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2 ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index ef69fed7952..7122de4789c 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1,7 +1,6 @@ ;;; rx.el --- sexp notation for regular expressions -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001-2011 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: FSF @@ -120,19 +119,17 @@ (nonl . not-newline) ; SRE (anything . (rx-anything 0 nil)) (any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE + (any . ".") ; sregex (in . any) (char . any) ; sregex (not-char . (rx-not-char 1 nil rx-check-any)) ; sregex (not . (rx-not 1 1 rx-check-not)) - ;; Partially consistent with sregex, whose `repeat' is like our - ;; `**'. (`repeat' with optional max arg and multiple sexp forms - ;; is ambiguous.) - (repeat . (rx-repeat 2 3)) + (repeat . (rx-repeat 2 nil)) (= . (rx-= 2 nil)) ; SRE (>= . (rx->= 2 nil)) ; SRE (** . (rx-** 2 nil)) ; SRE (submatch . (rx-submatch 1 nil)) ; SRE - (group . submatch) + (group . submatch) ; sregex (zero-or-more . (rx-kleene 1 nil)) (one-or-more . (rx-kleene 1 nil)) (zero-or-one . (rx-kleene 1 nil)) @@ -175,6 +172,7 @@ (category . (rx-category 1 1 rx-check-category)) (eval . (rx-eval 1 1)) (regexp . (rx-regexp 1 1 stringp)) + (regex . regexp) ; sregex (digit . "[[:digit:]]") (numeric . digit) ; SRE (num . digit) ; SRE @@ -295,15 +293,27 @@ regular expression strings.") `zero-or-more', and `one-or-more'. Dynamically bound.") -(defun rx-info (op) +(defun rx-info (op head) "Return parsing/code generation info for OP. If OP is the space character ASCII 32, return info for the symbol `?'. If OP is the character `?', return info for the symbol `??'. -See also `rx-constituents'." +See also `rx-constituents'. +If HEAD is non-nil, then OP is the head of a sexp, otherwise it's +a standalone symbol." (cond ((eq op ? ) (setq op '\?)) ((eq op ??) (setq op '\??))) - (while (and (not (null op)) (symbolp op)) - (setq op (cdr (assq op rx-constituents)))) + (let (old-op) + (while (and (not (null op)) (symbolp op)) + (setq old-op op) + (setq op (cdr (assq op rx-constituents))) + (when (if head (stringp op) (consp op)) + ;; We found something but of the wrong kind. Let's look for an + ;; alternate definition for the other case. + (let ((new-op + (cdr (assq old-op (cdr (memq (assq old-op rx-constituents) + rx-constituents)))))) + (if (and new-op (not (if head (stringp new-op) (consp new-op)))) + (setq op new-op)))))) op) @@ -311,7 +321,7 @@ See also `rx-constituents'." "Check FORM according to its car's parsing info." (unless (listp form) (error "rx `%s' needs argument(s)" form)) - (let* ((rx (rx-info (car form))) + (let* ((rx (rx-info (car form) 'head)) (nargs (1- (length form))) (min-args (nth 1 rx)) (max-args (nth 2 rx)) @@ -401,7 +411,7 @@ Only both edges of each range is checked." (setcdr m (1- char))))) ranges)) - + (defun rx-any-condense-range (args) "Condense by side effect ARGS as range for Rx `any'." (let (str @@ -564,7 +574,7 @@ ARG is optional." (condition-case nil (rx-form arg) (error "")))) - (eq arg 'word-boundary) + (eq arg 'word-boundary) (and (consp arg) (memq (car arg) '(not any in syntax category)))) (error "rx `not' syntax error: %s" arg)) @@ -643,14 +653,17 @@ If SKIP is non-nil, allow that number of items after the head, i.e. (defun rx-** (form) "Parse and produce code from FORM `(** N M ...)'." (rx-check form) - (setq form (cons 'repeat (cdr (rx-trans-forms form 2)))) - (rx-form form '*)) + (rx-form (cons 'repeat (cdr (rx-trans-forms form 2))) '*)) (defun rx-repeat (form) "Parse and produce code from FORM. -FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'." +FORM is either `(repeat N FORM1)' or `(repeat N M FORMS...)'." (rx-check form) + (if (> (length form) 4) + (setq form (rx-trans-forms form 2))) + (if (null (nth 2 form)) + (setq form (cons (nth 0 form) (cons (nth 1 form) (nthcdr 3 form))))) (cond ((= (length form) 3) (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) @@ -749,15 +762,18 @@ of all atomic regexps." "Parse and produce code from FORM, which is `(syntax SYMBOL)'." (rx-check form) (let* ((sym (cadr form)) - (syntax (assq sym rx-syntax))) + (syntax (cdr (assq sym rx-syntax)))) (unless syntax ;; Try sregex compatibility. - (let ((name (symbol-name sym))) - (if (= 1 (length name)) - (setq syntax (rassq (aref name 0) rx-syntax)))) + (cond + ((characterp sym) (setq syntax sym)) + ((symbolp sym) + (let ((name (symbol-name sym))) + (if (= 1 (length name)) + (setq syntax (aref name 0)))))) (unless syntax - (error "Unknown rx syntax `%s'" (cadr form)))) - (format "\\s%c" (cdr syntax)))) + (error "Unknown rx syntax `%s'" sym))) + (format "\\s%c" syntax))) (defun rx-check-category (form) @@ -811,7 +827,7 @@ shy groups around the result and some more in other functions." (cond ((integerp form) (regexp-quote (char-to-string form))) ((symbolp form) - (let ((info (rx-info form))) + (let ((info (rx-info form nil))) (cond ((stringp info) info) ((null info) @@ -819,7 +835,7 @@ shy groups around the result and some more in other functions." (t (funcall (nth 0 info) form))))) ((consp form) - (let ((info (rx-info (car form)))) + (let ((info (rx-info (car form) 'head))) (unless (consp info) (error "Unknown rx form `%s'" (car form))) (funcall (nth 0 info) form))) @@ -1144,5 +1160,4 @@ enclosed in `(and ...)'. (provide 'rx) -;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b ;;; rx.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 61daa21fcfa..d5bba20b1cd 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,7 +1,6 @@ ;;; shadow.el --- locate Emacs Lisp file shadowings -;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001-2011 Free Software Foundation, Inc. ;; Author: Terry Jones <terry@santafe.edu> ;; Keywords: lisp @@ -157,6 +156,34 @@ See the documentation for `list-load-path-shadows' for further information." (and (= (nth 7 (file-attributes f1)) (nth 7 (file-attributes f2))) (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) + +(defvar load-path-shadows-font-lock-keywords + `((,(format "hides \\(%s.*\\)" + (file-name-directory (locate-library "simple.el"))) + . (1 font-lock-warning-face))) + "Keywords to highlight in `load-path-shadows-mode'.") + +(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" + "Major mode for load-path shadows buffer." + (set (make-local-variable 'font-lock-defaults) + '((load-path-shadows-font-lock-keywords))) + (setq buffer-undo-list t + buffer-read-only t)) + +;; TODO use text-properties instead, a la dired. +(require 'button) +(define-button-type 'load-path-shadows-find-file + 'follow-link t +;; 'face 'default + 'action (lambda (button) + (let ((file (concat (button-get button 'shadow-file) ".el"))) + (or (file-exists-p file) + (setq file (concat file ".gz"))) + (if (file-readable-p file) + (pop-to-buffer (find-file-noselect file)) + (error "Cannot read file")))) + 'help-echo "mouse-2, RET: find this file") + ;;;###autoload (defun list-load-path-shadows (&optional stringp) @@ -240,14 +267,21 @@ function, `load-path-shadows-find'." ;; Create the *Shadows* buffer and display shadowings there. (let ((string (buffer-string))) (with-current-buffer (get-buffer-create "*Shadows*") - (fundamental-mode) ;run after-change-major-mode-hook. (display-buffer (current-buffer)) - (setq buffer-undo-list t - buffer-read-only nil) - (erase-buffer) - (insert string) - (insert msg "\n") - (setq buffer-read-only t))) + (load-path-shadows-mode) ; run after-change-major-mode-hook + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (insert msg "\n") + (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" + nil t) + (dotimes (i 2) + (make-button (match-beginning (1+ i)) + (match-end (1+ i)) + 'type 'load-path-shadows-find-file + 'shadow-file + (match-string (1+ i))))) + (goto-char (point-max))))) ;; We are non-interactive, print shadows via message. (unless (zerop n) (message "This site has duplicate Lisp libraries with the same name. @@ -265,5 +299,4 @@ version unless you know what you are doing.\n") (provide 'shadow) -;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 ;;; shadow.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 79a2543e1f8..702e8d880ba 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ ;;; smie.el --- Simple Minded Indentation Engine -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: languages, lisp, internal, parsing, indentation diff --git a/lisp/emacs-lisp/sregex.el b/lisp/emacs-lisp/sregex.el deleted file mode 100644 index 3163cca3c3d..00000000000 --- a/lisp/emacs-lisp/sregex.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; sregex.el --- symbolic regular expressions - -;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Bob Glickstein <bobg+sregex@zanshin.com> -;; Maintainer: Bob Glickstein <bobg+sregex@zanshin.com> -;; Keywords: extensions - -;; 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: - -;; This package allows you to write regular expressions using a -;; totally new, Lisp-like syntax. - -;; A "symbolic regular expression" (sregex for short) is a Lisp form -;; that, when evaluated, produces the string form of the specified -;; regular expression. Here's a simple example: - -;; (sregexq (or "Bob" "Robert")) => "Bob\\|Robert" - -;; As you can see, an sregex is specified by placing one or more -;; special clauses in a call to `sregexq'. The clause in this case is -;; the `or' of two strings (not to be confused with the Lisp function -;; `or'). The list of allowable clauses appears below. - -;; With sregex, it is never necessary to "escape" magic characters -;; that are meant to be taken literally; that happens automatically. -;; For example: - -;; (sregexq "M*A*S*H") => "M\\*A\\*S\\*H" - -;; It is also unnecessary to "group" parts of the expression together -;; to overcome operator precedence; that also happens automatically. -;; For example: - -;; (sregexq (opt (or "Bob" "Robert"))) => "\\(?:Bob\\|Robert\\)?" - -;; It *is* possible to group parts of the expression in order to refer -;; to them with numbered backreferences: - -;; (sregexq (group (or "Go" "Run")) -;; ", Spot, " -;; (backref 1)) => "\\(Go\\|Run\\), Spot, \\1" - -;; `sregexq' is a macro. Each time it is used, it constructs a simple -;; Lisp expression that then invokes a moderately complex engine to -;; interpret the sregex and render the string form. Because of this, -;; I don't recommend sprinkling calls to `sregexq' throughout your -;; code, the way one normally does with string regexes (which are -;; cheap to evaluate). Instead, it's wiser to precompute the regexes -;; you need wherever possible instead of repeatedly constructing the -;; same ones over and over. Example: - -;; (let ((field-regex (sregexq (opt "resent-") -;; (or "to" "cc" "bcc")))) -;; ... -;; (while ... -;; ... -;; (re-search-forward field-regex ...) -;; ...)) - -;; The arguments to `sregexq' are automatically quoted, but the -;; flipside of this is that it is not straightforward to include -;; computed (i.e., non-constant) values in `sregexq' expressions. So -;; `sregex' is a function that is like `sregexq' but which does not -;; automatically quote its values. Literal sregex clauses must be -;; explicitly quoted like so: - -;; (sregex '(or "Bob" "Robert")) => "Bob\\|Robert" - -;; but computed clauses can be included easily, allowing for the reuse -;; of common clauses: - -;; (let ((dotstar '(0+ any)) -;; (whitespace '(1+ (syntax ?-))) -;; (digits '(1+ (char (?0 . ?9))))) -;; (sregex 'bol dotstar ":" whitespace digits)) => "^.*:\\s-+[0-9]+" - -;; To use this package in a Lisp program, simply (require 'sregex). - -;; Here are the clauses allowed in an `sregex' or `sregexq' -;; expression: - -;; - a string -;; This stands for the literal string. If it contains -;; metacharacters, they will be escaped in the resulting regex -;; (using `regexp-quote'). - -;; - the symbol `any' -;; This stands for ".", a regex matching any character except -;; newline. - -;; - the symbol `bol' -;; Stands for "^", matching the empty string at the beginning of a line - -;; - the symbol `eol' -;; Stands for "$", matching the empty string at the end of a line - -;; - (group CLAUSE ...) -;; Groups the given CLAUSEs using "\\(" and "\\)". - -;; - (sequence CLAUSE ...) - -;; Groups the given CLAUSEs; may or may not use "\\(?:" and "\\)". -;; Clauses grouped by `sequence' do not count for purposes of -;; numbering backreferences. Use `sequence' in situations like -;; this: - -;; (sregexq (or "dog" "cat" -;; (sequence (opt "sea ") "monkey"))) -;; => "dog\\|cat\\|\\(?:sea \\)?monkey" - -;; where a single `or' alternate needs to contain multiple -;; subclauses. - -;; - (backref N) -;; Matches the same string previously matched by the Nth "group" in -;; the same sregex. N is a positive integer. - -;; - (or CLAUSE ...) -;; Matches any one of the CLAUSEs by separating them with "\\|". - -;; - (0+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or more -;; occurrences by appending "*". - -;; - (1+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches one or more -;; occurrences by appending "+". - -;; - (opt CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or one occurrence -;; by appending "?". - -;; - (repeat MIN MAX CLAUSE ...) -;; Concatenates the given CLAUSEs and constructs a regex matching at -;; least MIN occurrences and at most MAX occurrences. MIN must be a -;; non-negative integer. MAX must be a non-negative integer greater -;; than or equal to MIN; or MAX can be nil to mean "infinity." - -;; - (char CHAR-CLAUSE ...) -;; Creates a "character class" matching one character from the given -;; set. See below for how to construct a CHAR-CLAUSE. - -;; - (not-char CHAR-CLAUSE ...) -;; Creates a "character class" matching any one character not in the -;; given set. See below for how to construct a CHAR-CLAUSE. - -;; - the symbol `bot' -;; Stands for "\\`", matching the empty string at the beginning of -;; text (beginning of a string or of a buffer). - -;; - the symbol `eot' -;; Stands for "\\'", matching the empty string at the end of text. - -;; - the symbol `point' -;; Stands for "\\=", matching the empty string at point. - -;; - the symbol `word-boundary' -;; Stands for "\\b", matching the empty string at the beginning or -;; end of a word. - -;; - the symbol `not-word-boundary' -;; Stands for "\\B", matching the empty string not at the beginning -;; or end of a word. - -;; - the symbol `bow' -;; Stands for "\\<", matching the empty string at the beginning of a -;; word. - -;; - the symbol `eow' -;; Stands for "\\>", matching the empty string at the end of a word. - -;; - the symbol `wordchar' -;; Stands for the regex "\\w", matching a word-constituent character -;; (as determined by the current syntax table) - -;; - the symbol `not-wordchar' -;; Stands for the regex "\\W", matching a non-word-constituent -;; character. - -;; - (syntax CODE) -;; Stands for the regex "\\sCODE", where CODE is a syntax table code -;; (a single character). Matches any character with the requested -;; syntax. - -;; - (not-syntax CODE) -;; Stands for the regex "\\SCODE", where CODE is a syntax table code -;; (a single character). Matches any character without the -;; requested syntax. - -;; - (regex REGEX) -;; This is a "trapdoor" for including ordinary regular expression -;; strings in the result. Some regular expressions are clearer when -;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for -;; instance. However, see the note under "Bugs," below. - -;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -;; has one of the following forms: - -;; - a character -;; Adds that character to the set. - -;; - a string -;; Adds all the characters in the string to the set. - -;; - A pair (MIN . MAX) -;; Where MIN and MAX are characters, adds the range of characters -;; from MIN through MAX to the set. - -;;; To do: - -;; An earlier version of this package could optionally translate the -;; symbolic regex into other languages' syntaxes, e.g. Perl. For -;; instance, with Perl syntax selected, (sregexq (or "ab" "cd")) would -;; yield "ab|cd" instead of "ab\\|cd". It might be useful to restore -;; such a facility. - -;; - handle multibyte chars in sregex--char-aux -;; - add support for character classes ([:blank:], ...) -;; - add support for non-greedy operators *? and +? -;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?" - -;;; Bugs: - -;;; Code: - -(eval-when-compile (require 'cl)) - -;; Compatibility code for when we didn't have shy-groups -(defvar sregex--current-sregex nil) -(defun sregex-info () nil) -(defmacro sregex-save-match-data (&rest forms) (cons 'save-match-data forms)) -(defun sregex-replace-match (r &optional f l str subexp x) - (replace-match r f l str subexp)) -(defun sregex-match-string (c &optional i x) (match-string c i)) -(defun sregex-match-string-no-properties (count &optional in-string sregex) - (match-string-no-properties count in-string)) -(defun sregex-match-beginning (count &optional sregex) (match-beginning count)) -(defun sregex-match-end (count &optional sregex) (match-end count)) -(defun sregex-match-data (&optional sregex) (match-data)) -(defun sregex-backref-num (n &optional sregex) n) - - -(defun sregex (&rest exps) - "Symbolic regular expression interpreter. -This is exactly like `sregexq' (q.v.) except that it evaluates all its -arguments, so literal sregex clauses must be quoted. For example: - - (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -An argument-evaluating sregex interpreter lets you reuse sregex -subexpressions: - - (let ((dotstar '(0+ any)) - (whitespace '(1+ (syntax ?-))) - (digits '(1+ (char (?0 . ?9))))) - (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\"" - (sregex--sequence exps nil)) - -(defmacro sregexq (&rest exps) - "Symbolic regular expression interpreter. -This macro allows you to specify a regular expression (regexp) in -symbolic form, and converts it into the string form required by Emacs's -regex functions such as `re-search-forward' and `looking-at'. Here is -a simple example: - - (sregexq (or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -As you can see, an sregex is specified by placing one or more special -clauses in a call to `sregexq'. The clause in this case is the `or' -of two strings (not to be confused with the Lisp function `or'). The -list of allowable clauses appears below. - -With `sregex', it is never necessary to \"escape\" magic characters -that are meant to be taken literally; that happens automatically. -For example: - - (sregexq \"M*A*S*H\") => \"M\\\\*A\\\\*S\\\\*H\" - -It is also unnecessary to \"group\" parts of the expression together -to overcome operator precedence; that also happens automatically. -For example: - - (sregexq (opt (or \"Bob\" \"Robert\"))) => \"\\\\(Bob\\\\|Robert\\\\)?\" - -It *is* possible to group parts of the expression in order to refer -to them with numbered backreferences: - - (sregexq (group (or \"Go\" \"Run\")) - \", Spot, \" - (backref 1)) => \"\\\\(Go\\\\|Run\\\\), Spot, \\\\1\" - -If `sregexq' needs to introduce its own grouping parentheses, it will -automatically renumber your backreferences: - - (sregexq (opt \"resent-\") - (group (or \"to\" \"cc\" \"bcc\")) - \": \" - (backref 1)) => \"\\\\(resent-\\\\)?\\\\(to\\\\|cc\\\\|bcc\\\\): \\\\2\" - -`sregexq' is a macro. Each time it is used, it constructs a simple -Lisp expression that then invokes a moderately complex engine to -interpret the sregex and render the string form. Because of this, I -don't recommend sprinkling calls to `sregexq' throughout your code, -the way one normally does with string regexes (which are cheap to -evaluate). Instead, it's wiser to precompute the regexes you need -wherever possible instead of repeatedly constructing the same ones -over and over. Example: - - (let ((field-regex (sregexq (opt \"resent-\") - (or \"to\" \"cc\" \"bcc\")))) - ... - (while ... - ... - (re-search-forward field-regex ...) - ...)) - -The arguments to `sregexq' are automatically quoted, but the -flipside of this is that it is not straightforward to include -computed (i.e., non-constant) values in `sregexq' expressions. So -`sregex' is a function that is like `sregexq' but which does not -automatically quote its values. Literal sregex clauses must be -explicitly quoted like so: - - (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -but computed clauses can be included easily, allowing for the reuse -of common clauses: - - (let ((dotstar '(0+ any)) - (whitespace '(1+ (syntax ?-))) - (digits '(1+ (char (?0 . ?9))))) - (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\" - -Here are the clauses allowed in an `sregex' or `sregexq' expression: - -- a string - This stands for the literal string. If it contains - metacharacters, they will be escaped in the resulting regex - (using `regexp-quote'). - -- the symbol `any' - This stands for \".\", a regex matching any character except - newline. - -- the symbol `bol' - Stands for \"^\", matching the empty string at the beginning of a line - -- the symbol `eol' - Stands for \"$\", matching the empty string at the end of a line - -- (group CLAUSE ...) - Groups the given CLAUSEs using \"\\\\(\" and \"\\\\)\". - -- (sequence CLAUSE ...) - - Groups the given CLAUSEs; may or may not use \"\\\\(\" and \"\\\\)\". - Clauses grouped by `sequence' do not count for purposes of - numbering backreferences. Use `sequence' in situations like - this: - - (sregexq (or \"dog\" \"cat\" - (sequence (opt \"sea \") \"monkey\"))) - => \"dog\\\\|cat\\\\|\\\\(?:sea \\\\)?monkey\" - - where a single `or' alternate needs to contain multiple - subclauses. - -- (backref N) - Matches the same string previously matched by the Nth \"group\" in - the same sregex. N is a positive integer. - -- (or CLAUSE ...) - Matches any one of the CLAUSEs by separating them with \"\\\\|\". - -- (0+ CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or more - occurrences by appending \"*\". - -- (1+ CLAUSE ...) - Concatenates the given CLAUSEs and matches one or more - occurrences by appending \"+\". - -- (opt CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or one occurrence - by appending \"?\". - -- (repeat MIN MAX CLAUSE ...) - Concatenates the given CLAUSEs and constructs a regex matching at - least MIN occurrences and at most MAX occurrences. MIN must be a - non-negative integer. MAX must be a non-negative integer greater - than or equal to MIN; or MAX can be nil to mean \"infinity.\" - -- (char CHAR-CLAUSE ...) - Creates a \"character class\" matching one character from the given - set. See below for how to construct a CHAR-CLAUSE. - -- (not-char CHAR-CLAUSE ...) - Creates a \"character class\" matching any one character not in the - given set. See below for how to construct a CHAR-CLAUSE. - -- the symbol `bot' - Stands for \"\\\\`\", matching the empty string at the beginning of - text (beginning of a string or of a buffer). - -- the symbol `eot' - Stands for \"\\\\'\", matching the empty string at the end of text. - -- the symbol `point' - Stands for \"\\\\=\\=\", matching the empty string at point. - -- the symbol `word-boundary' - Stands for \"\\\\b\", matching the empty string at the beginning or - end of a word. - -- the symbol `not-word-boundary' - Stands for \"\\\\B\", matching the empty string not at the beginning - or end of a word. - -- the symbol `bow' - Stands for \"\\\\=\\<\", matching the empty string at the beginning of a - word. - -- the symbol `eow' - Stands for \"\\\\=\\>\", matching the empty string at the end of a word. - -- the symbol `wordchar' - Stands for the regex \"\\\\w\", matching a word-constituent character - (as determined by the current syntax table) - -- the symbol `not-wordchar' - Stands for the regex \"\\\\W\", matching a non-word-constituent - character. - -- (syntax CODE) - Stands for the regex \"\\\\sCODE\", where CODE is a syntax table code - (a single character). Matches any character with the requested - syntax. - -- (not-syntax CODE) - Stands for the regex \"\\\\SCODE\", where CODE is a syntax table code - (a single character). Matches any character without the - requested syntax. - -- (regex REGEX) - This is a \"trapdoor\" for including ordinary regular expression - strings in the result. Some regular expressions are clearer when - written the old way: \"[a-z]\" vs. (sregexq (char (?a . ?z))), for - instance. - -Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -has one of the following forms: - -- a character - Adds that character to the set. - -- a string - Adds all the characters in the string to the set. - -- A pair (MIN . MAX) - Where MIN and MAX are characters, adds the range of characters - from MIN through MAX to the set." - `(apply 'sregex ',exps)) - -(defun sregex--engine (exp combine) - (cond - ((stringp exp) - (if (and combine - (eq combine 'suffix) - (/= (length exp) 1)) - (concat "\\(?:" (regexp-quote exp) "\\)") - (regexp-quote exp))) - ((symbolp exp) - (ecase exp - (any ".") - (bol "^") - (eol "$") - (wordchar "\\w") - (not-wordchar "\\W") - (bot "\\`") - (eot "\\'") - (point "\\=") - (word-boundary "\\b") - (not-word-boundary "\\B") - (bow "\\<") - (eow "\\>"))) - ((consp exp) - (funcall (intern (concat "sregex--" - (symbol-name (car exp)))) - (cdr exp) - combine)) - (t (error "Invalid expression: %s" exp)))) - -(defun sregex--sequence (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'concat)) - exps ""))) - (if (eq combine 'suffix) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--or (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'or)) - exps "\\|"))) - (if (not (eq combine 'or)) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--group (exps combine) (concat "\\(" (sregex--sequence exps nil) "\\)")) - -(defun sregex--backref (exps combine) (concat "\\" (int-to-string (car exps)))) -(defun sregex--opt (exps combine) (concat (sregex--sequence exps 'suffix) "?")) -(defun sregex--0+ (exps combine) (concat (sregex--sequence exps 'suffix) "*")) -(defun sregex--1+ (exps combine) (concat (sregex--sequence exps 'suffix) "+")) - -(defun sregex--char (exps combine) (sregex--char-aux nil exps)) -(defun sregex--not-char (exps combine) (sregex--char-aux t exps)) - -(defun sregex--syntax (exps combine) (format "\\s%c" (car exps))) -(defun sregex--not-syntax (exps combine) (format "\\S%c" (car exps))) - -(defun sregex--regex (exps combine) - (if combine (concat "\\(?:" (car exps) "\\)") (car exps))) - -(defun sregex--repeat (exps combine) - (let* ((min (or (pop exps) 0)) - (minstr (number-to-string min)) - (max (pop exps))) - (concat (sregex--sequence exps 'suffix) - (concat "\\{" minstr "," - (when max (number-to-string max)) "\\}")))) - -(defun sregex--char-range (start end) - (let ((startc (char-to-string start)) - (endc (char-to-string end))) - (cond - ((> end (+ start 2)) (concat startc "-" endc)) - ((> end (+ start 1)) (concat startc (char-to-string (1+ start)) endc)) - ((> end start) (concat startc endc)) - (t startc)))) - -(defun sregex--char-aux (complement args) - ;; regex-opt does the same, we should join effort. - (let ((chars (make-bool-vector 256 nil))) ; Yeah, right! - (dolist (arg args) - (cond ((integerp arg) (aset chars arg t)) - ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg)) - ((consp arg) - (let ((start (car arg)) - (end (cdr arg))) - (when (> start end) - (let ((tmp start)) (setq start end) (setq end tmp))) - ;; now start <= end - (let ((i start)) - (while (<= i end) - (aset chars i t) - (setq i (1+ i)))))))) - ;; now chars is a map of the characters in the class - (let ((caret (aref chars ?^)) - (dash (aref chars ?-)) - (class (if (aref chars ?\]) "]" ""))) - (aset chars ?^ nil) - (aset chars ?- nil) - (aset chars ?\] nil) - - (let (start end) - (dotimes (i 256) - (if (aref chars i) - (progn - (unless start (setq start i)) - (setq end i) - (aset chars i nil)) - (when start - (setq class (concat class (sregex--char-range start end))) - (setq start nil)))) - (if start - (setq class (concat class (sregex--char-range start end))))) - - (if (> (length class) 0) - (setq class (concat class (if caret "^") (if dash "-"))) - (setq class (concat class (if dash "-") (if caret "^")))) - (if (and (not complement) (= (length class) 1)) - (regexp-quote class) - (concat "[" (if complement "^") class "]"))))) - -(provide 'sregex) - -;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492 -;;; sregex.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index b1a4664f1df..c012e48b590 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,7 +1,6 @@ ;;; syntax.el --- helper functions to find syntactic context -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2000-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -34,7 +33,6 @@ ;; - do something about the case where the syntax-table is changed. ;; This typically happens with tex-mode and its `$' operator. -;; - move font-lock-syntactic-keywords in here. Then again, maybe not. ;; - new functions `syntax-state', ... to replace uses of parse-partial-state ;; with something higher-level (similar to syntax-ppss-context). ;; - interaction with mmm-mode. @@ -47,6 +45,281 @@ (defvar font-lock-beginning-of-syntax-function) +;;; Applying syntax-table properties where needed. + +(defvar syntax-propertize-function nil + ;; Rather than a -functions hook, this is a -function because it's easier + ;; to do a single scan than several scans: with multiple scans, one cannot + ;; assume that the text before point has been propertized, so syntax-ppss + ;; gives unreliable results (and stores them in its cache to boot, so we'd + ;; have to flush that cache between each function, and we couldn't use + ;; syntax-ppss-flush-cache since that would not only flush the cache but also + ;; reset syntax-propertize--done which should not be done in this case). + "Mode-specific function to apply the syntax-table properties. +Called with 2 arguments: START and END. +This function can call `syntax-ppss' on any position before END, but it +should not call `syntax-ppss-flush-cache', which means that it should not +call `syntax-ppss' on some position and later modify the buffer on some +earlier position.") + +(defvar syntax-propertize-chunk-size 500) + +(defvar syntax-propertize-extend-region-functions + '(syntax-propertize-wholelines) + "Special hook run just before proceeding to propertize a region. +This is used to allow major modes to help `syntax-propertize' find safe buffer +positions as beginning and end of the propertized region. Its most common use +is to solve the problem of /identification/ of multiline elements by providing +a function that tries to find such elements and move the boundaries such that +they do not fall in the middle of one. +Each function is called with two arguments (START and END) and it should return +either a cons (NEW-START . NEW-END) or nil if no adjustment should be made. +These functions are run in turn repeatedly until they all return nil. +Put first the functions more likely to cause a change and cheaper to compute.") +;; Mark it as a special hook which doesn't use any global setting +;; (i.e. doesn't obey the element t in the buffer-local value). +(make-variable-buffer-local 'syntax-propertize-extend-region-functions) + +(defun syntax-propertize-wholelines (start end) + (goto-char start) + (cons (line-beginning-position) + (progn (goto-char end) + (if (bolp) (point) (line-beginning-position 2))))) + +(defun syntax-propertize-multiline (beg end) + "Let `syntax-propertize' pay attention to the syntax-multiline property." + (when (and (> beg (point-min)) + (get-text-property (1- beg) 'syntax-multiline)) + (setq beg (or (previous-single-property-change beg 'syntax-multiline) + (point-min)))) + ;; + (when (get-text-property end 'font-lock-multiline) + (setq end (or (text-property-any end (point-max) + 'syntax-multiline nil) + (point-max)))) + (cons beg end)) + +(defvar syntax-propertize--done -1 + "Position upto which syntax-table properties have been set.") +(make-variable-buffer-local 'syntax-propertize--done) + +(defun syntax-propertize--shift-groups (re n) + (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + +(defmacro syntax-propertize-precompile-rules (&rest rules) + "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. +The arg RULES can be of the same form as in `syntax-propertize-rules'. +The return value is an object that can be passed as a rule to +`syntax-propertize-rules'. +I.e. this is useful only when you want to share rules among several +syntax-propertize-functions." + (declare (debug syntax-propertize-rules)) + ;; Precompile? Yeah, right! + ;; Seriously, tho, this is a macro for 2 reasons: + ;; - we could indeed do some pre-compilation at some point in the future, + ;; e.g. fi/when we switch to a DFA-based implementation of + ;; syntax-propertize-rules. + ;; - this lets Edebug properly annotate the expressions inside RULES. + `',rules) + +(defmacro syntax-propertize-rules (&rest rules) + "Make a function that applies RULES for use in `syntax-propertize-function'. +The function will scan the buffer, applying the rules where they match. +The buffer is scanned a single time, like \"lex\" would, rather than once +per rule. + +Each RULE can be a symbol, in which case that symbol's value should be, +at macro-expansion time, a precompiled set of rules, as returned +by `syntax-propertize-precompile-rules'. + +Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where +REGEXP is an expression (evaluated at time of macro-expansion) that returns +a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to +apply the property SYNTAX to the chars matched by the subgroup NUMBER +of the regular expression, if NUMBER did match. +SYNTAX is an expression that returns a value to apply as `syntax-table' +property. Some expressions are handled specially: +- if SYNTAX is a string, then it is converted with `string-to-syntax'; +- if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP + will be applied to the buffer before running EXPS and if EXP is a string it + is also converted with `string-to-syntax'. +The SYNTAX expression is responsible to save the `match-data' if needed +for subsequent HIGHLIGHTs. +Also SYNTAX is free to move point, in which case RULES may not be applied to +some parts of the text or may be applied several times to other parts. + +Note: back-references in REGEXPs do not work." + (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. + (form &rest + (numberp + [&or stringp ;FIXME: Use &wrap + ("prog1" [&or stringp def-form] def-body) + def-form]))))) + (let ((newrules nil)) + (while rules + (if (symbolp (car rules)) + (setq rules (append (symbol-value (pop rules)) rules)) + (push (pop rules) newrules))) + (setq rules (nreverse newrules))) + (let* ((offset 0) + (branches '()) + ;; We'd like to use a real DFA-based lexer, usually, but since Emacs + ;; doesn't have one yet, we fallback on building one large regexp + ;; and use groups to determine which branch of the regexp matched. + (re + (mapconcat + (lambda (rule) + (let* ((orig-re (eval (car rule))) + (re orig-re)) + (when (and (assq 0 rule) (cdr rules)) + ;; If there's more than 1 rule, and the rule want to apply + ;; highlight to match 0, create an extra group to be able to + ;; tell when *this* match 0 has succeeded. + (incf offset) + (setq re (concat "\\(" re "\\)"))) + (setq re (syntax-propertize--shift-groups re offset)) + (let ((code '()) + (condition + (cond + ((assq 0 rule) (if (zerop offset) t + `(match-beginning ,offset))) + ((null (cddr rule)) + `(match-beginning ,(+ offset (car (cadr rule))))) + (t + `(or ,@(mapcar + (lambda (case) + `(match-beginning ,(+ offset (car case)))) + (cdr rule)))))) + (nocode t) + (offset offset)) + ;; If some of the subgroup rules include Elisp code, then we + ;; need to set the match-data so it's consistent with what the + ;; code expects. If not, then we can simply use shifted + ;; offset in our own code. + (unless (zerop offset) + (dolist (case (cdr rule)) + (unless (stringp (cadr case)) + (setq nocode nil))) + (unless nocode + (push `(let ((md (match-data 'ints))) + ;; Keep match 0 as is, but shift everything else. + (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md)) + (set-match-data md)) + code) + (setq offset 0))) + ;; Now construct the code for each subgroup rules. + (dolist (case (cdr rule)) + (assert (null (cddr case))) + (let* ((gn (+ offset (car case))) + (action (nth 1 case)) + (thiscode + (cond + ((stringp action) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax action)))) + ((eq (car-safe action) 'ignore) + (cdr action)) + ((eq (car-safe action) 'prog1) + (if (stringp (nth 1 action)) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax (nth 1 action))) + ,@(nthcdr 2 action)) + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,(nth 1 action))) + (if syntax + (put-text-property + mb me 'syntax-table syntax)) + ,@(nthcdr 2 action))))) + (t + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,action)) + (if syntax + (put-text-property + mb me 'syntax-table syntax)))))))) + + (if (or (not (cddr rule)) (zerop gn)) + (setq code (nconc (nreverse thiscode) code)) + (push `(if (match-beginning ,gn) + ;; Try and generate clean code with no + ;; extraneous progn. + ,(if (null (cdr thiscode)) + (car thiscode) + `(progn ,@thiscode))) + code)))) + (push (cons condition (nreverse code)) + branches)) + (incf offset (regexp-opt-depth orig-re)) + re)) + rules + "\\|"))) + `(lambda (start end) + (goto-char start) + (while (and (< (point) end) + (re-search-forward ,re end t)) + (cond ,@(nreverse branches)))))) + +(defun syntax-propertize-via-font-lock (keywords) + "Propertize for syntax in START..END 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'." + (lexical-let ((keywords keywords)) + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords)))))) + +(defun syntax-propertize (pos) + "Ensure that syntax-table properties are set upto POS." + (when (and syntax-propertize-function + (< syntax-propertize--done pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (let* ((start (max syntax-propertize--done (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end))) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + (funcall syntax-propertize-function start end)))))) + +;;; Incrementally compute and memoize parser state. + (defsubst syntax-ppss-depth (ppss) (nth 0 ppss)) @@ -92,6 +365,8 @@ point (where the PPSS is equivalent to nil).") (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." + ;; Set syntax-propertize to refontify anything past beg. + (setq syntax-propertize--done (min beg syntax-propertize--done)) ;; Flush invalid cache entries. (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg)) (setq syntax-ppss-cache (cdr syntax-ppss-cache))) @@ -128,6 +403,7 @@ the 2nd and 6th values of the returned state cannot be relied upon. Point is at POS when this function returns." ;; Default values. (unless pos (setq pos (point))) + (syntax-propertize pos) ;; (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last)) @@ -209,7 +485,8 @@ Point is at POS when this function returns." (funcall syntax-begin-function) ;; Make sure it's better. (> (point) pt-best)) - ;; Simple sanity check. + ;; Simple sanity checks. + (< (point) pos) ; backward-paragraph can fail here. (not (memq (get-text-property (point) 'face) '(font-lock-string-face font-lock-doc-face font-lock-comment-face)))) @@ -300,5 +577,4 @@ Point is at POS when this function returns." (provide 'syntax) -;; arch-tag: 302f1eeb-e77c-4680-a8c5-c543e01161a5 ;;; syntax.el ends here diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index f410d153b6e..b91b96b83e5 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,11 +1,11 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: spreadsheet lisp utility +;; Package: testcover ;; 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 @@ -721,5 +721,4 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 ;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index 374a280d9e0..2be026b98eb 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -1,10 +1,11 @@ ;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: safety lisp utility +;; Package: testcover ;; This file is part of GNU Emacs. @@ -137,5 +138,4 @@ (testcover-end "unsafep.el") (message "Done")) -;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 ;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index aeefa1bccac..08f757819f2 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,6 +1,6 @@ ;;;; testcover.el -- Visual code-coverage tool -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -534,5 +534,4 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) -;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 16d1af331fa..5f069226aa9 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,9 +1,9 @@ ;;; timer.el --- run a function with args at some time in future -;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1996, 2001-2011 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Package: emacs ;; This file is part of GNU Emacs. @@ -92,31 +92,20 @@ fire each time Emacs is idle for that many seconds." More precisely, the next value, after TIME, that is an integral multiple of SECS seconds since the epoch. SECS may be a fraction." (let ((time-base (ash 1 16))) - (if (fboundp 'atan) - ;; Use floating point, taking care to not lose precision. - (let* ((float-time-base (float time-base)) - (million 1000000.0) - (time-usec (+ (* million - (+ (* float-time-base (nth 0 time)) - (nth 1 time))) - (nth 2 time))) - (secs-usec (* million secs)) - (mod-usec (mod time-usec secs-usec)) - (next-usec (+ (- time-usec mod-usec) secs-usec)) - (time-base-million (* float-time-base million))) - (list (floor next-usec time-base-million) - (floor (mod next-usec time-base-million) million) - (floor (mod next-usec million)))) - ;; Floating point is not supported. - ;; Use integer arithmetic, avoiding overflow if possible. - (let* ((mod-sec (mod (+ (* (mod time-base secs) - (mod (nth 0 time) secs)) - (nth 1 time)) - secs)) - (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) - (list (+ (nth 0 time) (floor next-1-sec time-base)) - (mod next-1-sec time-base) - 0))))) + ;; Use floating point, taking care to not lose precision. + (let* ((float-time-base (float time-base)) + (million 1000000.0) + (time-usec (+ (* million + (+ (* float-time-base (nth 0 time)) + (nth 1 time))) + (nth 2 time))) + (secs-usec (* million secs)) + (mod-usec (mod time-usec secs-usec)) + (next-usec (+ (- time-usec mod-usec) secs-usec)) + (time-base-million (* float-time-base million))) + (list (floor next-usec time-base-million) + (floor (mod next-usec time-base-million) million) + (floor (mod next-usec million)))))) (defun timer-relative-time (time secs &optional usecs) "Advance TIME by SECS seconds and optionally USECS microseconds. @@ -321,7 +310,11 @@ This function is called, by name, directly by the C code." ;; We do this after rescheduling so that the handler function ;; can cancel its own timer successfully with cancel-timer. (condition-case nil - (apply (timer--function timer) (timer--args timer)) + ;; Timer functions should not change the current buffer. + ;; If they do, all kinds of nasty surprises can happen, + ;; and it can be hellish to track down their source. + (save-current-buffer + (apply (timer--function timer) (timer--args timer))) (error nil)) (if retrigger (setf (timer--triggered timer) nil))) @@ -438,8 +431,6 @@ This function returns a timer object which you can use in `cancel-timer'." "This is the timer function used for the timer made by `with-timeout'." (throw tag 'timeout)) -(put 'with-timeout 'lisp-indent-function 1) - (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") @@ -451,6 +442,7 @@ event (such as keyboard input, input from subprocesses, or a certain time); if the program loops without waiting in any way, the timeout will not be detected. \n(fn (SECONDS TIMEOUT-FORMS...) BODY)" + (declare (indent 1)) (let ((seconds (car list)) (timeout-forms (cdr list))) `(let ((with-timeout-tag (cons nil nil)) @@ -539,5 +531,4 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (provide 'timer) -;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 ;;; timer.el ends here diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index f310609ec11..3d3b371ad5c 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,7 +1,6 @@ ;;; tq.el --- utility to maintain a transaction queue -;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> ;; Maintainer: FSF @@ -167,5 +166,4 @@ This produces more reliable results with some processes." (provide 'tq) -;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 ;;; tq.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 77b8e1e118d..22c1f0e7ea7 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -1,7 +1,6 @@ ;;; trace.el --- tracing facility for Emacs Lisp functions -;; Copyright (C) 1993, 1998, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1998, 2000-2011 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF @@ -299,5 +298,4 @@ was not traced this is a noop." (provide 'trace) -;; arch-tag: cfd170a7-4932-4331-8c8b-b7151942e5a1 ;;; trace.el ends here diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 69c9569d685..0f08d77d4c3 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, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@member.fsf.org> ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> @@ -202,6 +202,9 @@ UNSAFEP-VARS is a list of symbols with local bindings." (dolist (x (nthcdr 3 form)) (setq reason (unsafep-progn (cdr x))) (if reason (throw 'unsafep reason)))))) + ((eq fun '\`) + ;; Backquoted form - safe if its expansion is. + (unsafep (cdr (backquote-process (cadr form))))) (t ;;First unsafep-function call above wasn't nil, no special case applies reason))))) @@ -258,5 +261,4 @@ If TO-BIND is t, check whether SYM is safe to bind." (local-variable-p sym))) `(global-variable ,sym)))) -;; arch-tag: 6216f98b-eb8f-467a-9c33-7a7644f50658 ;;; unsafep.el ends here diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 180296fb925..1fb8ac0c2b6 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, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2011 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -119,9 +119,9 @@ See also `warning-suppress-log-types'." :type '(repeat (repeat symbol)) :version "22.1") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-prefix-function nil "Function to generate warning prefixes. @@ -132,9 +132,9 @@ The warnings buffer is current when this function is called and the function can insert text in it. This text becomes the beginning of the warning.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-series nil "Non-nil means treat multiple `display-warning' calls as a series. @@ -146,16 +146,16 @@ A symbol with a function definition is like t, except also call that function before the next warning.") (put 'warning-series 'risky-local-variable t) -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-fill-prefix nil "Non-nil means fill each warning text using this string as `fill-prefix'.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-type-format (purecopy " (%s)") "Format for displaying the warning type in the warning message. @@ -241,6 +241,8 @@ See also `warning-series', `warning-prefix-function' and (with-current-buffer buffer ;; If we created the buffer, disable undo. (unless old + (special-mode) + (setq buffer-read-only t) (setq buffer-undo-list t)) (goto-char (point-max)) (when (and warning-series (symbolp warning-series)) @@ -248,6 +250,7 @@ See also `warning-series', `warning-prefix-function' and (prog1 (point-marker) (unless (eq warning-series t) (funcall warning-series))))) + (let ((inhibit-read-only t)) (unless (bolp) (newline)) (setq start (point)) @@ -262,7 +265,7 @@ See also `warning-series', `warning-prefix-function' and (let ((fill-prefix warning-fill-prefix) (fill-column 78)) (fill-region start (point)))) - (setq end (point)) + (setq end (point))) (when (and (markerp warning-series) (eq (marker-buffer warning-series) buffer)) (goto-char warning-series))) @@ -334,5 +337,4 @@ this is equivalent to `display-warning', using (provide 'warnings) -;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496 ;;; warnings.el ends here |