diff options
Diffstat (limited to 'lisp/emacs-lisp')
51 files changed, 3911 insertions, 926 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 9267bc8ac91..578e0877d30 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -7,6 +7,7 @@ ;; Maintainer: FSF ;; Created: 12 Dec 1992 ;; Keywords: extensions, lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 7728215bb91..ae490550021 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -6,6 +6,7 @@ ;; 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 +221,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 +248,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 +267,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 +299,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 +356,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 +379,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 +410,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 +465,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 +476,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 +507,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 +560,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 +586,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 +634,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 +669,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 +686,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 +835,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 +1033,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 5ae984ffdb0..4dd1a118ebd 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,11 +1,12 @@ ;; 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 +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 ;; Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -109,29 +110,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 +279,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 +348,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 +385,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 +417,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 +428,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 +442,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 +469,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 +485,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 +497,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 +558,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 +578,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 +698,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 +707,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 +778,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/backquote.el b/lisp/emacs-lisp/backquote.el index 998cee15342..96e2fb41e89 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -6,6 +6,7 @@ ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF ;; Keywords: extensions, internal +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 7605f457316..2666fc5b9b7 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -7,6 +7,7 @@ ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -1315,35 +1316,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 +1370,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 +1391,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 +2041,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 e6810fc8b72..0388435dbc2 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -7,6 +7,7 @@ ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -65,7 +66,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. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index cdfac80ca78..f04aad994f3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,12 +1,14 @@ ;;; 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 Free Software Foundation, Inc. +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; 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 +37,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 +248,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 +270,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 +880,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 +988,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 +1025,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 +1339,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 +1448,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 +1510,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 +1545,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 +1578,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 +1735,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 +1837,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 @@ -2131,6 +2186,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 +3384,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 +3842,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 +4295,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 +4345,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 d2abdcffe0d..84bfd706afc 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,7 +1,7 @@ ;;; chart.el --- Draw charts (bar charts, etc) -;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 @@ -62,11 +62,7 @@ (require 'eieio) ;;; Code: -(defvar chart-map nil "Keymap used in chart mode.") -(if chart-map - () - (setq chart-map (make-sparse-keymap)) - ) +(defvar chart-map (make-sparse-keymap) "Keymap used in chart mode.") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") @@ -529,9 +525,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 +746,4 @@ SORT-PRED if desired." (provide 'chart) -;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59 ;;; chart.el ends here diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e7455b3fbb7..0a3b3c94ff6 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,7 +1,7 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -201,9 +201,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 +250,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 +429,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 +511,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 +618,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 +708,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 +822,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 +943,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 +966,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 +1203,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 +1362,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 +1370,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 +1380,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 +1478,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 +1498,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 +1513,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 +1613,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 +1758,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 @@ -2002,49 +1983,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) @@ -2052,43 +2029,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 @@ -2256,8 +2229,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 @@ -2668,8 +2641,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") @@ -2679,5 +2651,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 3211f79c9e9..b7c908882ed 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -5,6 +5,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -685,7 +686,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)) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index e4f605d4fd0..4e7ada8851f 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -7,6 +7,7 @@ ;; Created: July 1987 ;; Maintainer: FSF ;; Keywords: lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 7640a0b1575..b1d934f08e0 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" "d93072a26c59f663a92b10df8bc28187") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "20c8c875ff1d11dd819e15a1f25afd73") ;;; 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" "49b7d96626dd8ba5d39551909edbd4c7") +;;;;;; 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" "979862b54946a5fcbbccdd90fa3f84d8") ;;; 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" "ec3ea1c77742734db8496272fe5721be") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "7b7531276ddf8457abecdd487d3cf0b7") ;;; 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 3e800c53008..76f677c6198 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -6,6 +6,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -128,6 +129,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 +639,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 +647,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 +662,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 +672,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 +713,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 +749,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 +794,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 +804,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 +816,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 +839,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 +851,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 +885,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 +901,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 +921,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 +936,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,7 +964,7 @@ Valid clauses are: loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) + (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) (temp (make-symbol "--cl-var--"))) (push (list var (if scr (list 'frame-selected-window scr) @@ -975,9 +982,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 +1000,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 +1013,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 +1028,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 +1059,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 +1087,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 +1114,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 +1165,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 +1748,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 +1761,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 +1805,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 +2630,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 +2782,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 a823e9015db..a5070e4acea 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -6,6 +6,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -47,6 +48,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 +85,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 +102,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) diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el index acfd3504ec7..776ce5e9ca1 100644 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@ -4,6 +4,7 @@ ;; 2006, 2007, 2008, 2009, 2010 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 diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 38ae511db78..9b275255b27 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -645,7 +645,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. diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 6f7a43af844..43eb61b0bee 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -158,13 +158,15 @@ When this is `function', only ask when called non-interactively." (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) (substring copyright-current-year -2)) (if (or noquery - ;; 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? "))))) + (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")))) @@ -224,8 +226,10 @@ version \\([0-9]+\\), or (at" (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)))) + (save-window-excursion + (switch-to-buffer (current-buffer)) + (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 diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index b8ff3c03ee9..17fcf7ad6c5 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -514,9 +514,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 diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index debef5535f5..3456d1a63fb 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -7,6 +7,7 @@ ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) ;; Maintainer: FSF ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -230,7 +231,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) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index a48816f99c6..9a703c96378 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -5,6 +5,7 @@ ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> +;; Package: emacs ;; Keywords: extensions lisp @@ -114,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!\" @@ -145,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"))) @@ -165,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 @@ -181,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." @@ -205,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. @@ -219,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) @@ -259,9 +277,15 @@ With zero or negative ARG turn mode off. (t (error "Invalid keymap %S" ,keymap)))) ,(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 @@ -341,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)) @@ -364,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 () @@ -558,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 470f0f67779..9992861fc3c 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -5,6 +5,7 @@ ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> +;; Package: emacs ;; This file is part of GNU Emacs. @@ -43,8 +44,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. @@ -150,6 +149,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))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 8bf20b0ccef..77953b37021 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,8 +1,8 @@ ;;; 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 -;; Free Software Foundation, Inc. +;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, +;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Maintainer: FSF @@ -885,17 +885,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 +905,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 +929,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) @@ -3009,7 +2991,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 +4011,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 +4435,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 +4446,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 b573af29ee2..91cb5642fb7 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el index a2b955a280b..e07a7b20d14 100644 --- a/lisp/emacs-lisp/eieio-comp.el +++ b/lisp/emacs-lisp/eieio-comp.el @@ -5,7 +5,8 @@ ;; 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 268d60fc196..12ff23b311f 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 5dc54f5c35e..b58fbfd3f08 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -4,6 +4,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 375ce0bc6d6..ca3850562c8 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index e4c1c50aa8f..e16c3a17438 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, tools +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 97022f0acbe..048093b858d 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -1629,6 +1629,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 +1638,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. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 961d576433a..b4845495c9e 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -530,13 +530,13 @@ 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) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index b9aa29decd0..39c45e82309 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -394,40 +394,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 +441,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 +472,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 +490,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 +1172,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/find-func.el b/lisp/emacs-lisp/find-func.el index 216d91baa7b..9d59337a7c7 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -213,6 +213,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 +228,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))))) diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index 3ca1df466b9..49d3a7075d4 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -60,7 +60,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")) diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index f98e452e343..371fe8af3ad 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,10 +1,11 @@ ;;; 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 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -25,36 +26,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 b6e8427ea1c..51b23c3f402 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -6,6 +6,7 @@ ;; 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. diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index b7cb8b93c2f..6a597429328 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -6,6 +6,7 @@ ;; Author: K. Shane Hartman ;; Maintainer: FSF ;; Keywords: help +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 8a1c753f5f6..7df65acb283 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -298,6 +298,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 +312,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 +456,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) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 4b58a4e68c2..5f17514763d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -5,6 +5,7 @@ ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -85,7 +86,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 +222,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 +407,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 +427,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 +462,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 +474,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 +1067,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 +1207,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 +1429,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 5703f1ee190..d0d1520a677 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -5,6 +5,7 @@ ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -140,9 +141,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 +635,60 @@ 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>"))))))) + (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>")))))))) ;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 364e3540703..6dfd47b4ad1 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -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) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el new file mode 100644 index 00000000000..38c4d5bbe35 --- /dev/null +++ b/lisp/emacs-lisp/package-x.el @@ -0,0 +1,227 @@ +;;; package-x.el --- Package extras + +;; Copyright (C) 2007, 2008, 2009, 2010 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..fecddcf16ed --- /dev/null +++ b/lisp/emacs-lisp/package.el @@ -0,0 +1,1700 @@ +;;; package.el --- Simple package system for Emacs + +;; Copyright (C) 2007, 2008, 2009, 2010 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) + (with-current-buffer (get-buffer-create "*Packages*") + (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) + ;; It's okay to use pop-to-buffer here. The package menu buffer + ;; has keybindings, and the user just typed `M-x list-packages', + ;; suggesting that they might want to use them. + (pop-to-buffer (current-buffer)))) + +;;;###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..5ff26b3dbc0 --- /dev/null +++ b/lisp/emacs-lisp/pcase.el @@ -0,0 +1,553 @@ +;;; pcase.el --- ML-style pattern-matching macro for Elisp + +;; Copyright (C) 2010 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/re-builder.el b/lisp/emacs-lisp/re-builder.el index ec1a704ce0b..1845effd5bb 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -61,14 +61,12 @@ ;; 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 +;; namely `read', `string', `rx', and `sregex' 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 @@ -128,12 +126,11 @@ (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', `sregex', 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 @@ -281,9 +278,8 @@ 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 + ;; Pull in packages as needed + (cond ((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 @@ -329,7 +325,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." @@ -489,10 +485,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 @@ -616,10 +612,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) + (cond ((eq reb-re-syntax 'sregex) (apply 'sregex (eval (car (read-from-string re))))) ((eq reb-re-syntax 'rx) (rx-to-string (eval (car (read-from-string re))))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index f70ad4047a7..116d7b93d90 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -96,19 +96,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 +125,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)) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index fe32a302045..e690cbaa1bc 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -157,6 +157,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 +268,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 +300,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/syntax.el b/lisp/emacs-lisp/syntax.el index 5cc89596ef5..b85399263d0 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -34,7 +34,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 +46,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 +366,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 +404,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 +486,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)))) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index cf5e79d2a26..8df70f4d979 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -6,6 +6,7 @@ ;; 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 diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index b300ee6dcef..47f931bf9d3 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -5,6 +5,7 @@ ;; 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. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index f3b8ddcd123..b12d9068676 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -4,6 +4,7 @@ ;; 2009, 2010 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Package: emacs ;; This file is part of GNU Emacs. @@ -92,31 +93,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 +311,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 +432,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 +443,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 +532,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/warnings.el b/lisp/emacs-lisp/warnings.el index 4adb93a852d..ba8c8ffc831 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -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))) |