diff options
Diffstat (limited to 'lisp/emacs-lisp')
66 files changed, 3974 insertions, 3049 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4babd844cf9..b4dcd24597a 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;; LCD Archive Entry: ;; advice|Hans Chalupsky|hans@cs.buffalo.edu| @@ -2470,27 +2468,11 @@ will clear the cache." "Take a macro function DEFINITION and make a lambda out of it." `(cdr ,definition)) -;; There is no way to determine whether some subr is a special form or not, -;; hence we need this list (which is probably out of date): -(defvar ad-special-forms - (let ((tem '(and catch cond condition-case defconst defmacro - defun defvar function if interactive let let* - or prog1 prog2 progn quote save-current-buffer - save-excursion save-restriction save-window-excursion - setq setq-default unwind-protect while - with-output-to-temp-buffer))) - ;; track-mouse could be void in some configurations. - (if (fboundp 'track-mouse) - (push 'track-mouse tem)) - (mapcar 'symbol-function tem))) - -(defmacro ad-special-form-p (definition) - ;;"non-nil if DEFINITION is a special form." - (list 'memq definition 'ad-special-forms)) - -(defmacro ad-interactive-p (definition) - ;;"non-nil if DEFINITION can be called interactively." - (list 'commandp definition)) +(defun ad-special-form-p (definition) + "Non-nil if and only if DEFINITION is a special form." + (if (and (symbolp definition) (fboundp definition)) + (setq definition (indirect-function definition))) + (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) (defmacro ad-subr-p (definition) ;;"non-nil if DEFINITION is a subr." @@ -2606,13 +2588,12 @@ that property, or otherwise use `(&rest ad-subr-args)'." docstring))) (defun ad-interactive-form (definition) - "Return the interactive form of DEFINITION." - (cond ((ad-compiled-p definition) - (and (commandp definition) - (list 'interactive (aref (ad-compiled-code definition) 5)))) - ((or (ad-advice-p definition) - (ad-lambda-p definition)) - (commandp (ad-lambda-expression definition))))) + "Return the interactive form of DEFINITION. +Like `interactive-form', but also works on pieces of advice." + (interactive-form + (if (ad-advice-p definition) + (ad-lambda-expression definition) + definition))) (defun ad-body-forms (definition) "Return the list of body forms of DEFINITION." @@ -2623,17 +2604,13 @@ that property, or otherwise use `(&rest ad-subr-args)'." (if (ad-interactive-form definition) 1 0)) (cdr (cdr (ad-lambda-expression definition))))))) -;; Matches the docstring of an advised definition. -;; The first group of the regexp matches the function name: -(defvar ad-advised-definition-docstring-regexp "^\\$ad-doc: \\(.+\\)\\$$") - (defun ad-make-advised-definition-docstring (function) "Make an identifying docstring for the advised definition of FUNCTION. Put function name into the documentation string so we can infer the name of the advised function from the docstring. This is needed to generate a proper advised docstring even if we are just given a -definition (also see the defadvice for `documentation')." - (format "$ad-doc: %s$" (prin1-to-string function))) +definition (see the code for `documentation')." + (propertize "Advice doc string" 'ad-advice-info function)) (defun ad-advised-definition-p (definition) "Return non-nil if DEFINITION was generated from advice information." @@ -2642,8 +2619,7 @@ definition (also see the defadvice for `documentation')." (ad-compiled-p definition)) (let ((docstring (ad-docstring definition))) (and (stringp docstring) - (string-match - ad-advised-definition-docstring-regexp docstring))))) + (get-text-property 0 'ad-advice-info docstring))))) (defun ad-definition-type (definition) "Return symbol that describes the type of DEFINITION." @@ -2697,12 +2673,9 @@ For that it has to be fbound with a non-autoload definition." (ad-with-auto-activation-disabled (require 'bytecomp) (let ((symbol (make-symbol "advice-compilation")) - (byte-compile-warnings - (if (listp byte-compile-warnings) byte-compile-warnings - byte-compile-warning-types))) + (byte-compile-warnings byte-compile-warnings)) (if (featurep 'cl) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings))) + (byte-compile-disable-warning 'cl-functions)) (fset symbol (symbol-function function)) (byte-compile symbol) (fset function (symbol-function symbol)))))) @@ -3016,7 +2989,9 @@ in any of these classes." (setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage))) (if origdoc (setq paragraphs (list origdoc))) (unless (eq style 'plain) - (push (concat "This " origtype " is advised.") paragraphs)) + (push (propertize (concat "This " origtype " is advised.") + 'face 'font-lock-warning-face) + paragraphs)) (ad-dolist (class ad-advice-classes) (ad-dolist (advice (ad-get-enabled-advices function class)) (setq advice-docstring @@ -3024,8 +2999,10 @@ in any of these classes." (if advice-docstring (push advice-docstring paragraphs)))) (setq origdoc (if paragraphs - ;; separate paragraphs with blank lines: - (mapconcat 'identity (nreverse paragraphs) "\n\n"))) + (propertize + ;; separate paragraphs with blank lines: + (mapconcat 'identity (nreverse paragraphs) "\n\n") + 'ad-advice-info function))) (help-add-fundoc-usage origdoc usage))) (defun ad-make-plain-docstring (function) @@ -3066,7 +3043,7 @@ in any of these classes." (ad-has-redefining-advice function)) (let* ((origdef (ad-real-orig-definition function)) (origname (ad-get-advice-info-field function 'origname)) - (orig-interactive-p (ad-interactive-p origdef)) + (orig-interactive-p (commandp origdef)) (orig-subr-p (ad-subr-p origdef)) (orig-special-form-p (ad-special-form-p origdef)) (orig-macro-p (ad-macro-p origdef)) @@ -3078,15 +3055,11 @@ in any of these classes." (interactive-form (cond (orig-macro-p nil) (advised-interactive-form) - ((ad-interactive-form origdef) - (if (and (symbolp function) (get function 'elp-info)) - (interactive-form (aref (get function 'elp-info) 2)) - (ad-interactive-form origdef))) - ;; Otherwise we must have a subr: make it interactive if - ;; we have to and initialize required arguments in case - ;; it is called interactively: - (orig-interactive-p - (interactive-form origdef)))) + ((interactive-form origdef) + (interactive-form + (if (and (symbolp function) (get function 'elp-info)) + (aref (get function 'elp-info) 2) + origdef))))) (orig-form (cond ((or orig-special-form-p orig-macro-p) ;; Special forms and macros will be advised into macros. @@ -3309,8 +3282,8 @@ advised definition from scratch." t (ad-arglist original-definition function)) (if (eq (ad-definition-type original-definition) 'function) - (equal (ad-interactive-form original-definition) - (ad-interactive-form cached-definition)))))) + (equal (interactive-form original-definition) + (interactive-form cached-definition)))))) (defun ad-get-cache-class-id (function class) "Return the part of FUNCTION's cache id that identifies CLASS." @@ -3357,8 +3330,8 @@ advised definition from scratch." (ad-arglist cached-definition)) (setq code 'interactive-form-mismatch) (or (null (nth 5 cache-id)) - (equal (ad-interactive-form original-definition) - (ad-interactive-form cached-definition))) + (equal (interactive-form original-definition) + (interactive-form cached-definition))) (setq code 'verified)))) code)) @@ -3942,24 +3915,6 @@ undone on exit of this macro." ;; during bootstrapping. (ad-define-subr-args 'documentation '(function &optional raw)) -(defadvice documentation (after ad-advised-docstring first disable preact) - "Builds an advised docstring if FUNCTION is advised." - ;; Because we get the function name from the advised docstring - ;; this will work for function names as well as for definitions: - (if (and (stringp ad-return-value) - (string-match - ad-advised-definition-docstring-regexp ad-return-value)) - (let ((function - (car (read-from-string - ad-return-value (match-beginning 1) (match-end 1))))) - (cond ((ad-is-advised function) - (setq ad-return-value (ad-make-advised-docstring function)) - ;; Handle optional `raw' argument: - (if (not (ad-get-arg 1)) - (setq ad-return-value - (substitute-command-keys ad-return-value)))))))) - - ;; @@ Starting, stopping and recovering from the advice package magic: ;; =================================================================== @@ -3968,9 +3923,7 @@ undone on exit of this macro." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate) - (ad-enable-advice 'documentation 'after 'ad-advised-docstring) - (ad-activate 'documentation 'compile)) + (ad-safe-fset 'ad-activate-internal 'ad-activate)) (defun ad-stop-advice () "Stop the automatic advice handling magic. @@ -3978,8 +3931,6 @@ You should only need this in case of Advice-related emergencies." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-disable-advice 'documentation 'after 'ad-advised-docstring) - (ad-update 'documentation) (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)) (defun ad-recover-normality () diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index e68ac56f622..1f9eb8f2c54 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -138,5 +136,5 @@ extra values are ignored. Returns the created alist." (provide 'assoc) -;;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc +;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc ;;; assoc.el ends here diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 6c502840c1b..caf9cb01960 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -72,7 +70,7 @@ files.") ("Geoff Voelker" "voelker") ("Gerd M,Av(Bllmann" "Gerd Moellmann") ("Hallvard B. Furuseth" "Hallvard B Furuseth") - ("Hrvoje Nik,B9(Bi,Bf(B" "Hrvoje Niksic") + ("Hrvoje Nik$,1!!(Bi$,1 '(B" "Hrvoje Niksic") (nil "(afs@hplb.hpl.hp.com)") (nil "<Use-Author-Address-Header@\\[127.1\\]>") (nil "Code Extracted") @@ -81,7 +79,7 @@ files.") ("Jaeyoun Chung" "Jae-youn Chung" "Jae-you Chung" "Chung Jae-youn") ("Jan Dj,Ad(Brv" "Jan D." "Jan Djarv") ("Jay K. Adams" "jka@ece.cmu.edu" "Jay Adams") - ("J,Ai(Br,At(Bme Marant" "J,bi(Br,bt(Bme Marant" "Jerome Marant") + ("J,Ai(Br,At(Bme Marant" "J,Ai(Br,At(Bme Marant" "Jerome Marant") ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") ("Johan Bockg,Ae(Brd" "Johan Bockgard") @@ -90,11 +88,11 @@ files.") ("Joseph Arceneaux" "Joe Arceneaux") ("Juan Le,As(Bn Lahoz Garc,Am(Ba" "Juan-Leon Lahoz Garcia") ("K. Shane Hartman" "Shane Hartman") - ("Kai Gro,A_(Bjohann" "Kai Grossjohann" "Kai Gro,b_(Bjohann" + ("Kai Gro,A_(Bjohann" "Kai Grossjohann" "Kai Gro,A_(Bjohann" "Kai.Grossjohann@Cs.Uni-Dortmund.De" "Kai.Grossjohann@Gmx.Net") ("Karl Berry" "K. Berry") - ("K,Aa(Broly L$,1 q(Brentey" "K,Aa(Broly L,Bu(Brentey" "L$,1 q(Brentey K,Aa(Broly") + ("K,Aa(Broly L$,1 q(Brentey" "K,Aa(Broly L$,1 q(Brentey" "L$,1 q(Brentey K,Aa(Broly") ("Kazushi Marukawa" "Kazushi") ("Ken Manheimer" "Kenneth Manheimer") ("Kenichi Handa" "Ken'ichi Handa" "Kenichi HANDA") @@ -113,7 +111,7 @@ files.") ("Mikio Nakajima" "Nakajima Mikio") ("Paul Eggert" "eggert") ("Paul Reilly" "(pmr@legacy.pajato.com)") - ("Pavel Jan,Bm(Bk" "Pavel Jan,Am(Bk Ml." "Pavel Jan,Am(Bk" "Pavel@Janik.Cz") + ("Pavel Jan,Am(Bk" "Pavel Jan,Am(Bk Ml." "Pavel Jan,Am(Bk" "Pavel@Janik.Cz") ("Per Abrahamsen" "Per Abhiddenware") ("Peter S. Galbraith" "Peter Galbraith") ("Peter Runestig" "Peter 'luna' Runestig") @@ -418,24 +416,6 @@ author and what he did in hash table TABLE. See the description of (nconc entry (list (cons action 1)))))))) -(defun authors-process-lines (program &rest args) - "Execute PROGRAM with ARGS, returning its output as a list of lines. -Signal an error if the program returns with a non-zero exit status." - (with-temp-buffer - (let ((status (apply 'call-process program nil (current-buffer) nil args))) - (unless (eq status 0) - (error "%s exited with status %s" program status)) - (goto-char (point-min)) - (let (lines) - (while (not (eobp)) - (setq lines (cons (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)) - lines)) - (forward-line 1)) - (nreverse lines))))) - - (defun authors-canonical-author-name (author) "Return a canonicalized form of AUTHOR, an author name. If AUTHOR has an alias, use that. Remove email addresses. Capitalize @@ -475,8 +455,8 @@ with the file and the number of each action. :wrote means the author wrote the file :changed means he changed the file COUNT times." - (let* ((enable-local-variables t) - (enable-local-eval t) + (let* ((enable-local-variables :safe) + (enable-local-eval nil) (existing-buffer (get-file-buffer log-file)) (buffer (find-file-noselect log-file)) author file pos) @@ -521,8 +501,8 @@ with the file and the number of each action. "Scan Lisp file FILE for author information. TABLE is a hash table to add author information to." (let* ((existing-buffer (get-file-buffer file)) - (enable-local-variables t) - (enable-local-eval t) + (enable-local-variables :safe) + (enable-local-eval nil) (buffer (find-file-noselect file))) (save-excursion (set-buffer buffer) @@ -605,7 +585,7 @@ Result is a buffer *Authors* containing authorship information, and a buffer *Authors Errors* containing references to unknown files." (interactive "DEmacs source directory: ") (setq root (expand-file-name root)) - (let ((logs (authors-process-lines "find" root "-name" "ChangeLog*")) + (let ((logs (process-lines find-program root "-name" "ChangeLog*")) (table (make-hash-table :test 'equal)) (buffer-name "*Authors*") authors-checked-files-alist @@ -617,7 +597,7 @@ buffer *Authors Errors* containing references to unknown files." (when (string-match "ChangeLog\\(.[0-9]+\\)?$" log) (message "Scanning %s..." log) (authors-scan-change-log log table))) - (let ((els (authors-process-lines "find" root "-name" "*.el"))) + (let ((els (process-lines find-program root "-name" "*.el"))) (dolist (file els) (message "Scanning %s..." file) (authors-scan-el file table))) @@ -666,8 +646,8 @@ list of their contributions.\n") (erase-buffer) (set-buffer-file-coding-system authors-coding-system) (insert "Unrecognized file entries found:\n\n") - (mapcar (lambda (f) (if (not (string-match "^[A-Za-z]+$" f)) (insert f "\n"))) - (sort authors-invalid-file-names 'string-lessp)) + (mapc (lambda (f) (if (not (string-match "^[A-Za-z]+$" f)) (insert f "\n"))) + (sort authors-invalid-file-names 'string-lessp)) (goto-char (point-min)) (compilation-mode) (message "Errors were found. See buffer %s" (buffer-name)))) @@ -690,5 +670,5 @@ the Emacs source tree, from which to build the file." (provide 'authors) -;;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1 +;; 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 0f11fc49ec2..6b1e6c6e975 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -41,15 +39,19 @@ A `.el' file can set this in its local variables section to make its autoloads go somewhere else. The autoload file is assumed to contain a trailer starting with a FormFeed character.") +;;;###autoload +(put 'generated-autoload-file 'safe-local-variable 'stringp) -(defconst generate-autoload-cookie ";;;###autoload" +;; This feels like it should be a defconst, but MH-E sets it to +;; ";;;###mh-autoload" for the autoloads that are to go into mh-loaddefs.el. +(defvar generate-autoload-cookie ";;;###autoload" "Magic comment indicating the following form should be autoloaded. Used by \\[update-file-autoloads]. This string should be meaningless to Lisp (e.g., a comment). This string is used: -;;;###autoload +\;;;###autoload \(defun function-to-be-autoloaded () ...) If this string appears alone on a line, the following form will be @@ -65,6 +67,8 @@ that text will be copied verbatim to `generated-autoload-file'.") (defconst generate-autoload-section-continuation ";;;;;; " "String to add on each continuation of the section header form.") +(defvar autoload-modified-buffers) ;Dynamically scoped var. + (defun make-autoload (form file) "Turn FORM into an autoload or defvar for source file FILE. Returns nil if FORM is not a special autoload form (i.e. a function definition @@ -149,16 +153,14 @@ or macro definition or a defcustom)." ;; the doc-string in FORM. ;; Those properties are now set in lisp-mode.el. +(defun autoload-generated-file () + (expand-file-name generated-autoload-file + ;; File-local settings of generated-autoload-file should + ;; be interpreted relative to the file's location, + ;; of course. + (if (not (local-variable-p 'generated-autoload-file)) + (expand-file-name "lisp" source-directory)))) -(defun autoload-trim-file-name (file) - ;; Returns a relative file path for FILE - ;; starting from the directory that loaddefs.el is in. - ;; That is normally a directory in load-path, - ;; which means Emacs will be able to find FILE when it looks. - ;; Any extra directory names here would prevent finding the file. - (setq file (expand-file-name file)) - (file-relative-name file - (file-name-directory generated-autoload-file))) (defun autoload-read-section-header () "Read a section header form. @@ -205,6 +207,7 @@ put the output in." (setcdr p nil) (princ "\n(" outbuf) (let ((print-escape-newlines t) + (print-quoted t) (print-escape-nonascii t)) (dolist (elt form) (prin1 elt outbuf) @@ -228,34 +231,41 @@ put the output in." outbuf)) (terpri outbuf))) (let ((print-escape-newlines t) + (print-quoted t) (print-escape-nonascii t)) (print form outbuf))))))) +(defun autoload-rubric (file &optional type) + "Return a string giving the appropriate autoload rubric for FILE. +TYPE (default \"autoloads\") is a string stating the type of +information contained in FILE." + (let ((basename (file-name-nondirectory file))) + (concat ";;; " basename + " --- automatically extracted " (or type "autoloads") "\n" + ";;\n" + ";;; Code:\n\n" + " \n" + "(provide '" (file-name-sans-extension basename) ")\n" + ";; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; coding: utf-8\n" + ";; End:\n" + ";;; " basename + " ends here\n"))) + (defun 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)) + (write-region (autoload-rubric file) nil file)) file) (defun autoload-insert-section-header (outbuf autoloads load-name file time) "Insert the section-header line, which lists the file name and which functions are in it, etc." (insert generate-autoload-section-header) - (prin1 (list 'autoloads autoloads load-name - (if (stringp file) (autoload-trim-file-name file) file) - time) + (prin1 (list 'autoloads autoloads load-name file time) outbuf) (terpri outbuf) ;; Break that line at spaces, to avoid very long lines. @@ -272,12 +282,14 @@ which lists the file name and which functions are in it, etc." (defun autoload-find-file (file) "Fetch file and put it in a temp buffer. Return the buffer." ;; It is faster to avoid visiting the file. + (setq file (expand-file-name file)) (with-current-buffer (get-buffer-create " *autoload-file*") (kill-all-local-variables) (erase-buffer) (setq buffer-undo-list t buffer-read-only nil) (emacs-lisp-mode) + (setq default-directory (file-name-directory file)) (insert-file-contents file nil) (let ((enable-local-variables :safe)) (hack-local-variables)) @@ -286,6 +298,12 @@ which lists the file name and which functions are in it, etc." (defvar no-update-autoloads nil "File local variable to prevent scanning this file for autoload cookies.") +(defun autoload-file-load-name (file) + (let ((name (file-name-nondirectory file))) + (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) + (substring name 0 (match-beginning 0)) + name))) + (defun generate-file-autoloads (file) "Insert at point a loaddefs autoload section for FILE. Autoloads are generated for defuns and defmacros in FILE @@ -294,101 +312,156 @@ If FILE is being visited in a buffer, the contents of the buffer are used. Return non-nil in the case where no autoloads were added at point." (interactive "fGenerate autoloads for file: ") - (let ((outbuf (current-buffer)) - (autoloads-done '()) - (load-name (let ((name (file-name-nondirectory file))) - (if (string-match "\\.elc?\\(\\.\\|$\\)" name) - (substring name 0 (match-beginning 0)) - name))) - (print-length nil) - (print-level nil) - (print-readably t) ; This does something in Lucid Emacs. - (float-output-format nil) - (done-any nil) - (visited (get-file-buffer file)) - output-start) - - ;; If the autoload section we create here uses an absolute - ;; file name for FILE in its header, and then Emacs is installed - ;; under a different path on another system, - ;; `update-autoloads-here' won't be able to find the files to be - ;; autoloaded. So, if FILE is in the same directory or a - ;; subdirectory of the current buffer's directory, we'll make it - ;; relative to the current buffer's directory. - (setq file (expand-file-name file)) - (let* ((source-truename (file-truename file)) - (dir-truename (file-name-as-directory - (file-truename default-directory))) - (len (length dir-truename))) - (if (and (< len (length source-truename)) - (string= dir-truename (substring source-truename 0 len))) - (setq file (substring source-truename len)))) - - (with-current-buffer (or visited - ;; It is faster to avoid visiting the file. - (autoload-find-file file)) - ;; Obey the no-update-autoloads file local variable. - (unless no-update-autoloads - (message "Generating autoloads for %s..." file) - (setq output-start (with-current-buffer outbuf (point))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - (search-forward generate-autoload-cookie) - (skip-chars-forward " \t") - (setq done-any t) - (if (eolp) - ;; Read the next form and make an autoload. - (let* ((form (prog1 (read (current-buffer)) - (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name))) - (if autoload - (push (nth 1 form) autoloads-done) - (setq autoload form)) - (let ((autoload-print-form-outbuf outbuf)) - (autoload-print-form autoload))) - - ;; Copy the rest of the line to the output. - (princ (buffer-substring - (progn - ;; Back up over whitespace, to preserve it. - (skip-chars-backward " \f\t") - (if (= (char-after (1+ (point))) ? ) - ;; Eat one space. - (forward-char 1)) - (point)) - (progn (forward-line 1) (point))) - outbuf))) - ((looking-at ";") - ;; Don't read the comment. - (forward-line 1)) - (t - (forward-sexp 1) - (forward-line 1)))))) - - (when done-any - (with-current-buffer outbuf - (save-excursion - ;; Insert the section-header line which lists the file name - ;; and which functions are in it, etc. - (goto-char output-start) - (autoload-insert-section-header - outbuf autoloads-done load-name file - (nth 5 (file-attributes file))) - (insert ";;; Generated autoloads from " - (autoload-trim-file-name file) "\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)))) - (not done-any))) + (autoload-generate-file-autoloads file (current-buffer))) + +;; 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 +;; `update-directory-autoloads' it's in between: we know the default +;; `outbuf' but we should obey any file-local setting of +;; `generated-autoload-file'. +(defun autoload-generate-file-autoloads (file &optional outbuf outfile) + "Insert an autoload section for FILE in the appropriate buffer. +Autoloads are generated for defuns and defmacros in FILE +marked by `generate-autoload-cookie' (which see). +If FILE is being visited in a buffer, the contents of the buffer are used. +OUTBUF is the buffer in which the autoload statements should be inserted. +If OUTBUF is nil, it will be determined by `autoload-generated-file'. + +If provided, OUTFILE is expected to be the file name of OUTBUF. +If OUTFILE is non-nil and FILE specifies a `generated-autoload-file' +different from OUTFILE, then OUTBUF is ignored. + +Return non-nil if and only if FILE adds no autoloads to OUTFILE +\(or OUTBUF if OUTFILE is nil)." + (catch 'done + (let ((autoloads-done '()) + (load-name (autoload-file-load-name file)) + (print-length nil) + (print-level nil) + (print-readably t) ; This does something in Lucid Emacs. + (float-output-format nil) + (visited (get-file-buffer file)) + (otherbuf nil) + (absfile (expand-file-name file)) + relfile + ;; nil until we found a cookie. + output-start) + + (with-current-buffer (or visited + ;; It is faster to avoid visiting the file. + (autoload-find-file file)) + ;; Obey the no-update-autoloads file local variable. + (unless no-update-autoloads + (message "Generating autoloads for %s..." file) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at (regexp-quote generate-autoload-cookie)) + ;; If not done yet, figure out where to insert this text. + (unless output-start + (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)) + ) + (search-forward generate-autoload-cookie) + (skip-chars-forward " \t") + (if (eolp) + (condition-case err + ;; Read the next form and make an autoload. + (let* ((form (prog1 (read (current-buffer)) + (or (bolp) (forward-line 1)))) + (autoload (make-autoload form load-name))) + (if autoload + (push (nth 1 form) autoloads-done) + (setq autoload form)) + (let ((autoload-print-form-outbuf outbuf)) + (autoload-print-form autoload))) + (error + (message "Error in %s: %S" file err))) + + ;; Copy the rest of the line to the output. + (princ (buffer-substring + (progn + ;; Back up over whitespace, to preserve it. + (skip-chars-backward " \f\t") + (if (= (char-after (1+ (point))) ? ) + ;; Eat one space. + (forward-char 1)) + (point)) + (progn (forward-line 1) (point))) + outbuf))) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t + (forward-sexp 1) + (forward-line 1)))))) + + (when output-start + (let ((secondary-autoloads-file-buf + (if (local-variable-p 'generated-autoload-file) + (current-buffer)))) + (with-current-buffer outbuf + (save-excursion + ;; Insert the section-header line which lists the file name + ;; and which functions are in it, etc. + (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")) + (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)))) +(defun autoload-save-buffers () + (while autoload-modified-buffers + (with-current-buffer (pop autoload-modified-buffers) + (save-buffer)))) + ;;;###autoload (defun update-file-autoloads (file &optional save-after) "Update the autoloads for FILE in `generated-autoload-file' @@ -398,80 +471,80 @@ save the buffer too. Return FILE if there was no autoload cookie in it, else nil." (interactive "fUpdate autoloads for file: \np") - (let ((load-name (let ((name (file-name-nondirectory file))) - (if (string-match "\\.elc?\\(\\.\\|$\\)" name) - (substring name 0 (match-beginning 0)) - name))) - (found nil) - (existing-buffer (get-file-buffer file)) - (no-autoloads nil)) - (save-excursion - ;; We want to get a value for generated-autoload-file from - ;; the local variables section if it's there. - (if existing-buffer - (set-buffer existing-buffer)) - ;; We must read/write the file without any code conversion, - ;; but still decode EOLs. - (let ((coding-system-for-read 'raw-text)) - (set-buffer (find-file-noselect - (autoload-ensure-default-file - (expand-file-name generated-autoload-file - (expand-file-name "lisp" - source-directory))))) - ;; This is to make generated-autoload-file have Unix EOLs, so - ;; that it is portable to all platforms. - (setq buffer-file-coding-system 'raw-text-unix)) - (or (> (buffer-size) 0) - (error "Autoloads file %s does not exist" buffer-file-name)) - (or (file-writable-p buffer-file-name) - (error "Autoloads file %s is not writable" buffer-file-name)) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - ;; Look for the section for LOAD-NAME. - (while (and (not found) - (search-forward generate-autoload-section-header nil t)) - (let ((form (autoload-read-section-header))) - (cond ((string= (nth 2 form) load-name) - ;; We found the section for this file. - ;; Check if it is up to date. - (let ((begin (match-beginning 0)) - (last-time (nth 4 form)) - (file-time (nth 5 (file-attributes file)))) - (if (and (or (null existing-buffer) - (not (buffer-modified-p existing-buffer))) - (listp last-time) (= (length last-time) 2) - (not (time-less-p last-time file-time))) - (progn - (if (interactive-p) - (message "\ -Autoload section for %s is up to date." - file)) - (setq found 'up-to-date)) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point)) - (setq found t)))) - ((string< load-name (nth 2 form)) - ;; We've come to a section alphabetically later than - ;; LOAD-NAME. We assume the file is in order and so - ;; there must be no section for LOAD-NAME. We will - ;; insert one before the section here. - (goto-char (match-beginning 0)) - (setq found 'new))))) - (or found - (progn - (setq found 'new) - ;; No later sections in the file. Put before the last page. - (goto-char (point-max)) - (search-backward "\f" nil t))) - (or (eq found 'up-to-date) - (setq no-autoloads (generate-file-autoloads file))))) - (and save-after - (buffer-modified-p) - (save-buffer)) - - (if no-autoloads file)))) + (let* ((autoload-modified-buffers nil) + (no-autoloads (autoload-generate-file-autoloads file))) + (if autoload-modified-buffers + (if save-after (autoload-save-buffers)) + (if (interactive-p) + (message "Autoload section for %s is up to date." file))) + (if no-autoloads file))) + +(defun autoload-find-destination (file) + "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)) + (existing-buffer (if buffer-file-name buf)) + (found nil)) + (with-current-buffer + ;; We used to use `raw-text' to read this file, but this causes + ;; problems when the file contains non-ASCII characters. + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file))) + ;; This is to make generated-autoload-file have Unix EOLs, so + ;; that it is portable to all platforms. + (unless (zerop (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)) + (or (file-writable-p buffer-file-name) + (error "Autoloads file %s is not writable" buffer-file-name)) + (widen) + (goto-char (point-min)) + ;; Look for the section for LOAD-NAME. + (while (and (not found) + (search-forward generate-autoload-section-header nil t)) + (let ((form (autoload-read-section-header))) + (cond ((string= (nth 2 form) load-name) + ;; We found the section for this file. + ;; Check if it is up to date. + (let ((begin (match-beginning 0)) + (last-time (nth 4 form)) + (file-time (nth 5 (file-attributes file)))) + (if (and (or (null existing-buffer) + (not (buffer-modified-p existing-buffer))) + (or + ;; last-time is the time-stamp (specifying + ;; the last time we looked at the file) and + ;; the file hasn't been changed since. + (and (listp last-time) (= (length last-time) 2) + (not (time-less-p last-time file-time))) + ;; last-time is an MD5 checksum instead. + (and (stringp last-time) + (equal last-time + (md5 buf nil nil 'emacs-mule))))) + (throw 'up-to-date nil) + (autoload-remove-section begin) + (setq found t)))) + ((string< load-name (nth 2 form)) + ;; We've come to a section alphabetically later than + ;; LOAD-NAME. We assume the file is in order and so + ;; there must be no section for LOAD-NAME. We will + ;; insert one before the section here. + (goto-char (match-beginning 0)) + (setq found t))))) + (or found + (progn + ;; No later sections in the file. Put before the last page. + (goto-char (point-max)) + (search-backward "\f" nil t))) + (unless (memq (current-buffer) autoload-modified-buffers) + (push (current-buffer) autoload-modified-buffers)) + (current-buffer))))) (defun autoload-remove-section (begin) (goto-char begin) @@ -499,20 +572,21 @@ directory or directories specified." (directory-files (expand-file-name dir) t files-re)) dirs))) + (done ()) (this-time (current-time)) - (no-autoloads nil) ;files with no autoload cookies. - (autoloads-file - (expand-file-name generated-autoload-file - (expand-file-name "lisp" source-directory))) - (top-dir (file-name-directory autoloads-file))) + ;; Files with no autoload cookies or whose autoloads go to other + ;; files because of file-local autoload-generated-file settings. + (no-autoloads nil) + (autoload-modified-buffers nil)) (with-current-buffer - (find-file-noselect (autoload-ensure-default-file autoloads-file)) + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file))) (save-excursion ;; Canonicalize file names and remove the autoload file itself. - (setq files (delete (autoload-trim-file-name buffer-file-name) - (mapcar 'autoload-trim-file-name files))) + (setq files (delete (file-relative-name buffer-file-name) + (mapcar 'file-relative-name files))) (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) @@ -532,19 +606,27 @@ directory or directories specified." (push file no-autoloads) (setq files (delete file files))))))) ((not (stringp file))) - ((not (file-exists-p (expand-file-name file top-dir))) - ;; Remove the obsolete section. + ((or (not (file-exists-p file)) + ;; Remove duplicates as well, just in case. + (member file done)) + ;; Remove the obsolete section. (autoload-remove-section (match-beginning 0))) - ((equal (nth 4 form) (nth 5 (file-attributes file))) + ((not (time-less-p (nth 4 form) + (nth 5 (file-attributes file)))) ;; File hasn't changed. nil) (t - (update-file-autoloads file))) + (autoload-remove-section (match-beginning 0)) + (if (autoload-generate-file-autoloads + file (current-buffer) buffer-file-name) + (push file no-autoloads)))) + (push file done) (setq files (delete file files))))) ;; Elements remaining in FILES have no existing autoload sections yet. - (setq no-autoloads - (append no-autoloads - (delq nil (mapcar 'update-file-autoloads files)))) + (dolist (file files) + (if (autoload-generate-file-autoloads file nil buffer-file-name) + (push file no-autoloads))) + (when no-autoloads ;; Sort them for better readability. (setq no-autoloads (sort no-autoloads 'string<)) @@ -555,7 +637,10 @@ directory or directories specified." (current-buffer) nil nil no-autoloads this-time) (insert generate-autoload-section-trailer)) - (save-buffer)))) + (save-buffer) + ;; In case autoload entries were added to other files because of + ;; file-local autoload-generated-file settings. + (autoload-save-buffers)))) (define-obsolete-function-alias 'update-autoloads-from-directories 'update-directory-autoloads "22.1") @@ -564,8 +649,9 @@ directory or directories specified." (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. Calls `update-directory-autoloads' on the command line arguments." - (apply 'update-directory-autoloads command-line-args-left) - (setq command-line-args-left nil)) + (let ((args command-line-args-left)) + (setq command-line-args-left nil) + (apply 'update-directory-autoloads args))) (provide 'autoload) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el new file mode 100644 index 00000000000..c0288cdc749 --- /dev/null +++ b/lisp/emacs-lisp/avl-tree.el @@ -0,0 +1,470 @@ +;;; avl-tree.el --- balanced binary trees, AVL-trees + +;; Copyright (C) 1995, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Per Cederqvist <ceder@lysator.liu.se> +;; Inge Wallin <inge@lysator.liu.se> +;; Thomas Bellman <bellman@lysator.liu.se> +;; Maintainer: FSF +;; Created: 10 May 1991 +;; Keywords: extensions, data structures + +;; 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: + +;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of +;; two elements, the root node and the compare function. The actual tree +;; has a dummy node as its root with the real root in the left pointer. +;; +;; Each node of the tree consists of one data element, one left +;; sub-tree and one right sub-tree. Each node also has a balance +;; count, which is the difference in depth of the left and right +;; sub-trees. +;; +;; The functions with names of the form "avl-tree--" are intended for +;; internal use only. + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; ================================================================ +;;; Functions and macros handling an AVL tree node. + +(defstruct (avl-tree--node + ;; We force a representation without tag so it matches the + ;; pre-defstruct representation. Also we use the underlying + ;; representation in the implementation of avl-tree--node-branch. + (:type vector) + (:constructor nil) + (:constructor avl-tree--node-create (left right data balance)) + (:copier nil)) + left right data balance) + +(defalias 'avl-tree--node-branch 'aref + ;; This implementation is efficient but breaks the defstruct abstraction. + ;; An alternative could be + ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node) + "Get value of a branch of a node. + +NODE is the node, and BRANCH is the branch. +0 for left pointer, 1 for right pointer and 2 for the data.\" +\(fn node branch)") +;; The funcall/aref trick doesn't work for the setf method, unless we try +;; and access the underlying setter function, but this wouldn't be +;; portable either. +(defsetf avl-tree--node-branch aset) + + +;; ================================================================ +;;; Internal functions for use in the AVL tree package + +(defstruct (avl-tree- + ;; A tagged list is the pre-defstruct representation. + ;; (:type list) + :named + (:constructor nil) + (:constructor avl-tree-create (cmpfun)) + (:predicate avl-tree-p) + (:copier nil)) + (dummyroot (avl-tree--node-create nil nil nil 0)) + cmpfun) + +(defmacro avl-tree--root (tree) + ;; Return the root node for an avl-tree. INTERNAL USE ONLY. + `(avl-tree--node-left (avl-tree--dummyroot tree))) +(defsetf avl-tree--root (tree) (node) + `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) + +;; ---------------------------------------------------------------- +;; Deleting data + +(defun avl-tree--del-balance1 (node branch) + ;; Rebalance a tree and return t if the height of the tree has shrunk. + (let ((br (avl-tree--node-branch node branch)) + p1 b1 p2 b2 result) + (cond + ((< (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) + t) + + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) +1) + nil) + + (t + ;; Rebalance. + (setq p1 (avl-tree--node-right br) + b1 (avl-tree--node-balance p1)) + (if (>= b1 0) + ;; Single RR rotation. + (progn + (setf (avl-tree--node-right br) (avl-tree--node-left p1)) + (setf (avl-tree--node-left p1) br) + (if (= 0 b1) + (progn + (setf (avl-tree--node-balance br) +1) + (setf (avl-tree--node-balance p1) -1) + (setq result nil)) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance p1) 0) + (setq result t)) + (setf (avl-tree--node-branch node branch) p1) + result) + + ;; Double RL rotation. + (setq p2 (avl-tree--node-left p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) p1) + (setf (avl-tree--node-right br) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) br) + (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) + (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) + (setf (avl-tree--node-branch node branch) p2) + (setf (avl-tree--node-balance p2) 0) + t))))) + +(defun avl-tree--del-balance2 (node branch) + (let ((br (avl-tree--node-branch node branch)) + p1 b1 p2 b2 result) + (cond + ((> (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) + t) + + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) -1) + nil) + + (t + ;; Rebalance. + (setq p1 (avl-tree--node-left br) + b1 (avl-tree--node-balance p1)) + (if (<= b1 0) + ;; Single LL rotation. + (progn + (setf (avl-tree--node-left br) (avl-tree--node-right p1)) + (setf (avl-tree--node-right p1) br) + (if (= 0 b1) + (progn + (setf (avl-tree--node-balance br) -1) + (setf (avl-tree--node-balance p1) +1) + (setq result nil)) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance p1) 0) + (setq result t)) + (setf (avl-tree--node-branch node branch) p1) + result) + + ;; Double LR rotation. + (setq p2 (avl-tree--node-right p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) p1) + (setf (avl-tree--node-left br) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) br) + (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) + (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) + (setf (avl-tree--node-branch node branch) p2) + (setf (avl-tree--node-balance p2) 0) + t))))) + +(defun avl-tree--do-del-internal (node branch q) + (let ((br (avl-tree--node-branch node branch))) + (if (avl-tree--node-right br) + (if (avl-tree--do-del-internal br +1 q) + (avl-tree--del-balance2 node branch)) + (setf (avl-tree--node-data q) (avl-tree--node-data br)) + (setf (avl-tree--node-branch node branch) + (avl-tree--node-left br)) + t))) + +(defun avl-tree--do-delete (cmpfun root branch data) + ;; Return t if the height of the tree has shrunk. + (let ((br (avl-tree--node-branch root branch))) + (cond + ((null br) + nil) + + ((funcall cmpfun data (avl-tree--node-data br)) + (if (avl-tree--do-delete cmpfun br 0 data) + (avl-tree--del-balance1 root branch))) + + ((funcall cmpfun (avl-tree--node-data br) data) + (if (avl-tree--do-delete cmpfun br 1 data) + (avl-tree--del-balance2 root branch))) + + (t + ;; Found it. Let's delete it. + (cond + ((null (avl-tree--node-right br)) + (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) + t) + + ((null (avl-tree--node-left br)) + (setf (avl-tree--node-branch root branch) (avl-tree--node-right br)) + t) + + (t + (if (avl-tree--do-del-internal br 0 br) + (avl-tree--del-balance1 root branch)))))))) + +;; ---------------------------------------------------------------- +;; Entering data + +(defun avl-tree--enter-balance1 (node branch) + ;; Rebalance a tree and return t if the height of the tree has grown. + (let ((br (avl-tree--node-branch node branch)) + p1 p2 b2 result) + (cond + ((< (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) + nil) + + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) +1) + t) + + (t + ;; Tree has grown => Rebalance. + (setq p1 (avl-tree--node-right br)) + (if (> (avl-tree--node-balance p1) 0) + ;; Single RR rotation. + (progn + (setf (avl-tree--node-right br) (avl-tree--node-left p1)) + (setf (avl-tree--node-left p1) br) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-branch node branch) p1)) + + ;; Double RL rotation. + (setq p2 (avl-tree--node-left p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) p1) + (setf (avl-tree--node-right br) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) br) + (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) + (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) + (setf (avl-tree--node-branch node branch) p2)) + (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) + nil)))) + +(defun avl-tree--enter-balance2 (node branch) + ;; Return t if the tree has grown. + (let ((br (avl-tree--node-branch node branch)) + p1 p2 b2) + (cond + ((> (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) 0) + nil) + + ((= (avl-tree--node-balance br) 0) + (setf (avl-tree--node-balance br) -1) + t) + + (t + ;; Balance was -1 => Rebalance. + (setq p1 (avl-tree--node-left br)) + (if (< (avl-tree--node-balance p1) 0) + ;; Single LL rotation. + (progn + (setf (avl-tree--node-left br) (avl-tree--node-right p1)) + (setf (avl-tree--node-right p1) br) + (setf (avl-tree--node-balance br) 0) + (setf (avl-tree--node-branch node branch) p1)) + + ;; Double LR rotation. + (setq p2 (avl-tree--node-right p1) + b2 (avl-tree--node-balance p2)) + (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) + (setf (avl-tree--node-left p2) p1) + (setf (avl-tree--node-left br) (avl-tree--node-right p2)) + (setf (avl-tree--node-right p2) br) + (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) + (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) + (setf (avl-tree--node-branch node branch) p2)) + (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) + nil)))) + +(defun avl-tree--do-enter (cmpfun root branch data) + ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. + (let ((br (avl-tree--node-branch root branch))) + (cond + ((null br) + ;; Data not in tree, insert it. + (setf (avl-tree--node-branch root branch) + (avl-tree--node-create nil nil data 0)) + t) + + ((funcall cmpfun data (avl-tree--node-data br)) + (and (avl-tree--do-enter cmpfun br 0 data) + (avl-tree--enter-balance2 root branch))) + + ((funcall cmpfun (avl-tree--node-data br) data) + (and (avl-tree--do-enter cmpfun br 1 data) + (avl-tree--enter-balance1 root branch))) + + (t + (setf (avl-tree--node-data br) data) + nil)))) + +;; ---------------------------------------------------------------- + +(defun avl-tree--mapc (map-function root) + ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. + ;; The function is applied in-order. + ;; + ;; Note: MAP-FUNCTION is applied to the node and not to the data itself. + ;; INTERNAL USE ONLY. + (let ((node root) + (stack nil) + (go-left t)) + (push nil stack) + (while node + (if (and go-left + (avl-tree--node-left node)) + ;; Do the left subtree first. + (progn + (push node stack) + (setq node (avl-tree--node-left node))) + ;; Apply the function... + (funcall map-function node) + ;; and do the right subtree. + (setq node (if (setq go-left (avl-tree--node-right node)) + (avl-tree--node-right node) + (pop stack))))))) + +(defun avl-tree--do-copy (root) + ;; Copy the avl tree with ROOT as root. + ;; Highly recursive. INTERNAL USE ONLY. + (if (null root) + nil + (avl-tree--node-create + (avl-tree--do-copy (avl-tree--node-left root)) + (avl-tree--do-copy (avl-tree--node-right root)) + (avl-tree--node-data root) + (avl-tree--node-balance root)))) + + +;; ================================================================ +;;; The public functions which operate on AVL trees. + +(defalias 'avl-tree-compare-function 'avl-tree--cmpfun + "Return the comparison function for the avl tree TREE. + +\(fn TREE)") + +(defun avl-tree-empty (tree) + "Return t if avl tree TREE is emtpy, otherwise return nil." + (null (avl-tree--root tree))) + +(defun avl-tree-enter (tree data) + "In the avl tree TREE insert DATA. +Return DATA." + (avl-tree--do-enter (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 + data) + data) + +(defun avl-tree-delete (tree data) + "From the avl tree TREE, delete DATA. +Return the element in TREE which matched DATA, +nil if no element matched." + (avl-tree--do-delete (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 + data)) + +(defun avl-tree-member (tree data) + "Return the element in the avl tree TREE which matches DATA. +Matching uses the compare function previously specified in +`avl-tree-create' when TREE was created. + +If there is no such element in the tree, the value is nil." + (let ((node (avl-tree--root tree)) + (compare-function (avl-tree--cmpfun tree)) + found) + (while (and node + (not found)) + (cond + ((funcall compare-function data (avl-tree--node-data node)) + (setq node (avl-tree--node-left node))) + ((funcall compare-function (avl-tree--node-data node) data) + (setq node (avl-tree--node-right node))) + (t + (setq found t)))) + (if node + (avl-tree--node-data node) + nil))) + +(defun avl-tree-map (__map-function__ tree) + "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." + (avl-tree--mapc + (lambda (node) + (setf (avl-tree--node-data node) + (funcall __map-function__ (avl-tree--node-data node)))) + (avl-tree--root tree))) + +(defun avl-tree-first (tree) + "Return the first element in TREE, or nil if TREE is empty." + (let ((node (avl-tree--root tree))) + (when node + (while (avl-tree--node-left node) + (setq node (avl-tree--node-left node))) + (avl-tree--node-data node)))) + +(defun avl-tree-last (tree) + "Return the last element in TREE, or nil if TREE is empty." + (let ((node (avl-tree--root tree))) + (when node + (while (avl-tree--node-right node) + (setq node (avl-tree--node-right node))) + (avl-tree--node-data node)))) + +(defun avl-tree-copy (tree) + "Return a copy of the avl tree TREE." + (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) + (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) + new-tree)) + +(defun avl-tree-flatten (tree) + "Return a sorted list containing all elements of TREE." + (nreverse + (let ((treelist nil)) + (avl-tree--mapc + (lambda (node) (push (avl-tree--node-data node) treelist)) + (avl-tree--root tree)) + treelist))) + +(defun avl-tree-size (tree) + "Return the number of elements in TREE." + (let ((treesize 0)) + (avl-tree--mapc + (lambda (data) (setq treesize (1+ treesize))) + (avl-tree--root tree)) + treesize)) + +(defun avl-tree-clear (tree) + "Clear the avl tree TREE." + (setf (avl-tree--root tree) nil)) + +(provide 'avl-tree) + +;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 +;;; avl-tree.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index abf3ae8a06d..d35aec49ae2 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -91,8 +89,7 @@ For example (backquote-list* 'a 'b 'c) => (a b . c)" (defconst backquote-splice-symbol '\,@ "Symbol used to represent a splice inside a backquote.") -;;;###autoload -(defmacro backquote (arg) +(defmacro backquote (structure) "Argument STRUCTURE describes a template to build. The whole structure acts as if it were quoted except for certain @@ -106,11 +103,10 @@ b => (ba bb bc) ; assume b has this value `(a ,@b c) => (a ba bb bc c) ; splice in the value of b Vectors work just like lists. Nested backquotes are permitted." - (cdr (backquote-process arg))) + (cdr (backquote-process structure))) ;; GNU Emacs has no reader macros -;;;###autoload (defalias '\` (symbol-function 'backquote)) ;; backquote-process returns a dotted-pair of a tag (0, 1, or 2) and diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index b5a88c0d643..62b1f058d88 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -1,24 +1,25 @@ ;;; benchmark.el --- support for benchmarking code -;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008 +;; Free Software Foundation, Inc. ;; Author: Dave Love <fx@gnu.org> ;; Keywords: lisp, extensions -;; This file is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. -;; This file is distributed in the hope that it will be useful, +;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -115,5 +116,5 @@ non-interactive use see also `benchmark-run' and (provide 'benchmark) -;;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946 +;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946 ;;; benchmark.el ends here diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 0ceba28b7e2..e697cef97c3 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -651,5 +649,5 @@ The port (if any) is omitted. IP can be a string, as well." (provide 'bindat) -;;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb +;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d4c21e5ddb8..c34c88cb72d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -31,7 +29,7 @@ ;; "No matter how hard you try, you can't make a racehorse out of a pig. ;; You can, however, make a faster pig." ;; -;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code +;; Or, to put it another way, the Emacs byte compiler is a VW Bug. This code ;; makes it be a VW Bug with fuel injection and a turbocharger... You're ;; still not going to make it go faster than 70 mph, but it might be easier ;; to get it there. @@ -185,6 +183,7 @@ ;;; Code: (require 'bytecomp) +(eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) (if (aref byte-code-vector 0) @@ -382,7 +381,9 @@ form)) ((or (byte-code-function-p fn) (eq 'lambda (car-safe fn))) - (byte-compile-unfold-lambda form)) + (byte-optimize-form-code-walker + (byte-compile-unfold-lambda form) + for-effect)) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -627,13 +628,32 @@ ;; ;; It is now safe to optimize code such that it introduces new bindings. -;; I'd like this to be a defsubst, but let's not be self-referential... -(defmacro byte-compile-trueconstp (form) - ;; Returns non-nil if FORM is a non-nil constant. - `(cond ((consp ,form) (eq (car ,form) 'quote)) - ((not (symbolp ,form))) - ((eq ,form t)) - ((keywordp ,form)))) +(defsubst byte-compile-trueconstp (form) + "Return non-nil if FORM always evaluates to a non-nil value." + (while (eq (car-safe form) 'progn) + (setq form (car (last (cdr form))))) + (cond ((consp form) + (case (car form) + (quote (cadr form)) + ;; Can't use recursion in a defsubst. + ;; (progn (byte-compile-trueconstp (car (last (cdr form))))) + )) + ((not (symbolp form))) + ((eq form t)) + ((keywordp form)))) + +(defsubst byte-compile-nilconstp (form) + "Return non-nil if FORM always evaluates to a nil value." + (while (eq (car-safe form) 'progn) + (setq form (car (last (cdr form))))) + (cond ((consp form) + (case (car form) + (quote (null (cadr form))) + ;; Can't use recursion in a defsubst. + ;; (progn (byte-compile-nilconstp (car (last (cdr form))))) + )) + ((not (symbolp form)) nil) + ((null form)))) ;; If the function is being called with constant numeric args, ;; evaluate as much as possible at compile-time. This optimizer @@ -992,17 +1012,17 @@ (setq rest form) (while (setq rest (cdr rest)) (cond ((byte-compile-trueconstp (car-safe (car rest))) - (cond ((eq rest (cdr form)) - (setq form - (if (cdr (car rest)) - (if (cdr (cdr (car rest))) - (cons 'progn (cdr (car rest))) - (nth 1 (car rest))) - (car (car rest))))) + ;; This branch will always be taken: kill the subsequent ones. + (cond ((eq rest (cdr form)) ;First branch of `cond'. + (setq form `(progn ,@(car rest)))) ((cdr rest) (setq form (copy-sequence form)) (setcdr (memq (car rest) form) nil))) - (setq rest nil))))) + (setq rest nil)) + ((and (consp (car rest)) + (byte-compile-nilconstp (caar rest))) + ;; This branch will never be taken: kill its body. + (setcdr (car rest) nil))))) ;; ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) (if (eq 'cond (car-safe form)) @@ -1016,17 +1036,26 @@ form)) (defun byte-optimize-if (form) + ;; (if (progn <insts> <test>) <rest>) ==> (progn <insts> (if <test> <rest>)) ;; (if <true-constant> <then> <else...>) ==> <then> ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) ;; (if <test> <then> nil) ==> (if <test> <then>) (let ((clause (nth 1 form))) - (cond ((byte-compile-trueconstp clause) - (nth 2 form)) - ((null clause) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form))) + (cond ((and (eq (car-safe clause) 'progn) + ;; `clause' is a proper list. + (null (cdr (last clause)))) + (if (null (cddr clause)) + ;; A trivial `progn'. + (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) + (nconc (butlast clause) + (list + (byte-optimize-if + `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) + ((byte-compile-trueconstp clause) + `(progn ,clause ,(nth 2 form))) + ((byte-compile-nilconstp clause) + `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) (list 'if clause (nth 2 form)) @@ -1139,9 +1168,11 @@ (defun byte-optimize-featurep (form) ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so we ;; can safely optimize away this test. - (if (member (cdr-safe form) '((quote xemacs) (quote sxemacs))) + (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) nil - form)) + (if (member (cdr-safe form) '(((quote emacs)))) + t + form))) (put 'set 'byte-optimizer 'byte-optimize-set) (defun byte-optimize-set (form) @@ -1186,8 +1217,9 @@ char-equal char-to-string char-width compare-strings concat coordinates-in-window-p copy-alist copy-sequence copy-marker cos count-lines + decode-char decode-time default-boundp default-value documentation downcase - elt exp expt encode-time error-message-string + elt encode-char exp expt encode-time error-message-string fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p @@ -1198,7 +1230,7 @@ int-to-string intern-soft keymap-parent length local-variable-if-set-p local-variable-p log log10 logand - logb logior lognot logxor lsh + logb logior lognot logxor lsh langinfo make-list make-string make-symbol marker-buffer max member memq min mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string @@ -1210,6 +1242,7 @@ string-to-int string-to-number substring sxhash symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte + string-to-multibyte tan truncate unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name user-variable-p @@ -1221,7 +1254,8 @@ '(arrayp atom bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp - car-safe case-table-p cdr-safe char-or-string-p commandp cons consp + car-safe case-table-p cdr-safe char-or-string-p characterp + charsetp commandp cons consp current-buffer current-global-map current-indentation current-local-map current-minor-mode-maps current-time current-time-string current-time-zone @@ -1233,11 +1267,13 @@ invocation-directory invocation-name keymapp line-beginning-position line-end-position list listp - make-marker mark mark-marker markerp memory-limit minibuffer-window + make-marker mark mark-marker markerp max-char + memory-limit minibuffer-window mouse-movement-p natnump nlistp not null number-or-marker-p numberp one-window-p overlayp - point point-marker point-min point-max preceding-char processp + point point-marker point-min point-max preceding-char primary-charset + processp recent-keys recursion-depth safe-length selected-frame selected-window sequencep standard-case-table standard-syntax-table stringp subrp symbolp @@ -1328,7 +1364,7 @@ ;; This list contains numbers, which are pc values, ;; before each instruction. (defun byte-decompile-bytecode (bytes constvec) - "Turns BYTECODE into lapcode, referring to CONSTVEC." + "Turn BYTECODE into lapcode, referring to CONSTVEC." (let ((byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0)) @@ -1998,17 +2034,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) - (mapcar (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-optimize-form - byte-optimize-body - byte-optimize-predicate - byte-optimize-binary-predicate - ;; Inserted some more than necessary, to speed it up. - byte-optimize-form-code-walker - byte-optimize-lapcode)))) + (mapc (lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-optimize-form + byte-optimize-body + byte-optimize-predicate + byte-optimize-binary-predicate + ;; Inserted some more than necessary, to speed it up. + byte-optimize-form-code-walker + byte-optimize-lapcode)))) nil) ;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index ecf2ed57dac..03fd5bfee3c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -103,16 +101,11 @@ The return value of this function is not used." (eval-and-compile (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) -(defmacro declare-function (&rest args) - "In Emacs 22, does nothing. In 23, it will suppress byte-compiler warnings. -This definition is so that packages may take advantage of the -Emacs 23 feature and still remain compatible with Emacs 22." - nil) - (defun make-obsolete (obsolete-name current-name &optional when) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. The warning will say that CURRENT-NAME should be used instead. -If CURRENT-NAME is a string, that is the `use instead' message. +If CURRENT-NAME is a string, that is the `use instead' message +\(it should end with a period, and not start with a capital). If provided, WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." (interactive "aMake function obsolete: \nxObsoletion replacement: ") @@ -166,6 +159,15 @@ is equivalent to the following two lines of code: \(defvaralias 'old-var 'new-var \"old-var's doc.\") \(make-obsolete-variable 'old-var 'new-var \"22.1\") +If CURRENT-NAME is a defcustom (more generally, any variable +where OBSOLETE-NAME may be set, e.g. in a .emacs file, before the +alias is defined), then the define-obsolete-variable-alias +statement should be placed before the defcustom. This is so that +any user customizations are applied before the defcustom tries to +initialize the variable (this is due to the way `defvaralias' works). +Exceptions to this rule occur for define-obsolete-variable-alias +statements that are autoloaded, or in files dumped with Emacs. + See the docstrings of `defvaralias' and `make-obsolete-variable' or Info node `(elisp)Variable Aliases' for more details." (declare (doc-string 4)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4bd94a6bc56..5bb2d760980 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -98,9 +96,12 @@ ;; `obsolete' (obsolete variables and functions) ;; `noruntime' (calls to functions only defined ;; within `eval-when-compile') -;; `cl-warnings' (calls to CL functions) +;; `cl-functions' (calls to CL functions) ;; `interactive-only' (calls to commands that are ;; not good to call from Lisp) +;; `make-local' (dubious calls to +;; `make-variable-buffer-local') +;; `mapcar' (mapcar called for effect) ;; byte-compile-compatibility Whether the compiler should ;; generate .elc files which can be loaded into ;; generic emacs 18. @@ -338,7 +339,8 @@ 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) + obsolete noruntime cl-functions interactive-only + make-local mapcar) "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). @@ -356,33 +358,79 @@ Elements of the list may be: cl-functions calls to runtime functions from the CL package (as distinguished from macros and aliases). interactive-only - commands that normally shouldn't be called from Lisp code." + commands that normally shouldn't be called from Lisp code. + make-local calls to make-variable-buffer-local that may be incorrect. + mapcar mapcar called for effect. + +If the list begins with `not', then the remaining elements specify warnings to +suppress. For example, (not mapcar) will suppress warnings about mapcar." :group 'bytecomp :type `(choice (const :tag "All" t) (set :menu-tag "Some" (const free-vars) (const unresolved) (const callargs) (const redefine) (const obsolete) (const noruntime) - (const cl-functions) (const interactive-only)))) + (const cl-functions) (const interactive-only) + (const make-local) (const mapcar)))) ;;;###autoload(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p) ;;;###autoload (defun byte-compile-warnings-safe-p (x) + "Return non-nil if X is valid as a value of `byte-compile-warnings'." (or (booleanp x) (and (listp x) + (if (eq (car x) 'not) (setq x (cdr x)) + t) (equal (mapcar (lambda (e) - (when (memq e '(free-vars unresolved - callargs redefine - obsolete noruntime - cl-functions interactive-only)) + (when (memq e byte-compile-warning-types) e)) x) x)))) +(defun byte-compile-warning-enabled-p (warning) + "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." + (or (eq byte-compile-warnings t) + (if (eq (car byte-compile-warnings) 'not) + (not (memq warning byte-compile-warnings)) + (memq warning byte-compile-warnings)))) + +;;;###autoload +(defun byte-compile-disable-warning (warning) + "Change `byte-compile-warnings' to disable WARNING. +If `byte-compile-warnings' is t, set it to `(not WARNING)'. +Otherwise, if the first element is `not', add WARNING, else remove it. +Normally you should let-bind `byte-compile-warnings' before calling this, +else the global value will be modified." + (setq byte-compile-warnings + (cond ((eq byte-compile-warnings t) + (list 'not warning)) + ((eq (car byte-compile-warnings) 'not) + (if (memq warning byte-compile-warnings) + byte-compile-warnings + (append byte-compile-warnings (list warning)))) + (t + (delq warning byte-compile-warnings))))) + +;;;###autoload +(defun byte-compile-enable-warning (warning) + "Change `byte-compile-warnings' to enable WARNING. +If `byte-compile-warnings' is `t', do nothing. Otherwise, if the +first element is `not', remove WARNING, else add it. +Normally you should let-bind `byte-compile-warnings' before calling this, +else the global value will be modified." + (or (eq byte-compile-warnings t) + (setq byte-compile-warnings + (cond ((eq (car byte-compile-warnings) 'not) + (delq warning byte-compile-warnings)) + ((memq warning byte-compile-warnings) + byte-compile-warnings) + (t + (append byte-compile-warnings (list warning))))))) + (defvar byte-compile-interactive-only-functions '(beginning-of-buffer end-of-buffer replace-string replace-regexp - insert-file insert-buffer insert-file-literally) + insert-file insert-buffer insert-file-literally previous-line next-line) "List of commands that are not meant to be called from Lisp.") (defvar byte-compile-not-obsolete-var nil @@ -811,7 +859,7 @@ otherwise pop it") (setcar (cdr bytes) (logand pc 255)) (setcar bytes (lsh pc -8)))) (setq patchlist (cdr patchlist)))) - (concat (nreverse bytes)))) + (apply 'unibyte-string (nreverse bytes)))) ;;; compile-time evaluation @@ -822,7 +870,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((hist-orig load-history) (hist-nil-orig current-load-list)) (prog1 (eval form) - (when (memq 'noruntime byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'noruntime) (let ((hist-new load-history) (hist-nil-new current-load-list)) ;; Go through load-history, look for newly loaded files @@ -850,14 +898,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (push s byte-compile-noruntime-functions)) (when (and (consp s) (eq t (car s))) (push (cdr s) old-autoloads))))))) - (when (memq 'cl-functions byte-compile-warnings) - (let ((hist-new load-history) - (hist-nil-new current-load-list)) + (when (byte-compile-warning-enabled-p 'cl-functions) + (let ((hist-new load-history)) ;; Go through load-history, look for newly loaded files ;; and mark all the functions defined therein. (while (and hist-new (not (eq hist-new hist-orig))) - (let ((xs (pop hist-new)) - old-autoloads) + (let ((xs (pop hist-new))) ;; Make sure the file was not already loaded before. (when (and (equal (car xs) "cl") (not (assoc (car xs) hist-orig))) (byte-compile-find-cl-functions))))))))) @@ -870,8 +916,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((tem current-load-list)) (while (not (eq tem hist-nil-orig)) (when (equal (car tem) '(require . cl)) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings))) + (byte-compile-disable-warning 'cl-functions)) (setq tem (cdr tem))))))) ;;; byte compiler messages @@ -879,6 +924,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defvar byte-compile-current-form nil) (defvar byte-compile-dest-file nil) (defvar byte-compile-current-file nil) +(defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) ;; Log something that isn't a warning. @@ -1003,6 +1049,9 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-warning-series (&rest ignore) nil) +;; (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. ;; Return the position of the start of the page in the log buffer. ;; But do nothing in batch mode. @@ -1036,8 +1085,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. - (unless (eq major-mode 'compilation-mode) - (compilation-mode)) + (unless (derived-mode-p 'compilation-mode) (compilation-mode)) (compilation-forget-errors) pt)))) @@ -1057,6 +1105,22 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) +(defun byte-compile-warn-obsolete (symbol) + "Warn that SYMBOL (a variable or function) is obsolete." + (when (byte-compile-warning-enabled-p 'obsolete) + (let* ((funcp (get symbol 'byte-obsolete-info)) + (obsolete (or funcp (get symbol 'byte-obsolete-variable))) + (instead (car obsolete)) + (asof (if funcp (nth 2 obsolete) (cdr obsolete)))) + (byte-compile-warn "`%s' is an obsolete %s%s%s" symbol + (if funcp "function" "variable") + (if asof (concat " (as of Emacs " asof ")") "") + (cond ((stringp instead) + (concat "; " instead)) + (instead + (format "; use `%s' instead." instead)) + (t ".")))))) + (defun byte-compile-report-error (error-info) "Report Lisp error in compilation. ERROR-INFO is the error data." (setq byte-compiler-error-flag t) @@ -1066,17 +1130,10 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;;; Used by make-obsolete. (defun byte-compile-obsolete (form) - (let* ((new (get (car form) 'byte-obsolete-info)) - (handler (nth 1 new)) - (when (nth 2 new))) - (byte-compile-set-symbol-position (car form)) - (if (memq 'obsolete byte-compile-warnings) - (byte-compile-warn "`%s' is an obsolete function%s; %s" (car form) - (if when (concat " (as of Emacs " when ")") "") - (if (stringp (car new)) - (car new) - (format "use `%s' instead." (car new))))) - (funcall (or handler 'byte-compile-normal-call) form))) + (byte-compile-set-symbol-position (car form)) + (byte-compile-warn-obsolete (car form)) + (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler + 'byte-compile-normal-call) form)) ;; Compiler options @@ -1209,7 +1266,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-fdefinition (car form) t))) (sig (if (and def (not (eq def t))) (byte-compile-arglist-signature - (if (eq 'lambda (car-safe def)) + (if (memq (car-safe def) '(declared lambda)) (nth 1 def) (if (byte-code-function-p def) (aref def 0) @@ -1262,7 +1319,7 @@ extra args." (get (car form) 'byte-compile-format-like)) (let ((nfields (with-temp-buffer (insert (nth 1 form)) - (goto-char 1) + (goto-char (point-min)) (let ((n 0)) (while (re-search-forward "%." nil t) (unless (eq ?% (char-after (1+ (match-beginning 0)))) @@ -1279,20 +1336,29 @@ extra args." ;; Warn if a custom definition fails to specify :group. (defun byte-compile-nogroup-warn (form) - (let ((keyword-args (cdr (cdr (cdr (cdr form))))) - (name (cadr form))) - (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) - '((custom-declare-group . defgroup) - (custom-declare-face . defface) - (custom-declare-variable . defcustom)))) - (cadr name))))) + (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) + byte-compile-current-group) + ;; The group will be provided implicitly. + nil + (let ((keyword-args (cdr (cdr (cdr (cdr form))))) + (name (cadr form))) + (or (not (eq (car-safe name) 'quote)) + (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (not (and (consp name) (eq (car name) 'quote))) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) + '((custom-declare-group . defgroup) + (custom-declare-face . defface) + (custom-declare-variable . defcustom)))) + (cadr name))) + ;; Update the current group, if needed. + (if (and byte-compile-current-file ;Only when byte-compiling a whole file. + (eq (car form) 'custom-declare-group) + (eq (car-safe name) 'quote)) + (setq byte-compile-current-group (cadr name)))))) ;; Warn if the function or macro is being redefined with a different ;; number of arguments. @@ -1345,16 +1411,11 @@ extra args." (unless byte-compile-cl-functions (dolist (elt load-history) (when (and (stringp (car elt)) - (string-match "^cl\\>" (car elt))) - (setq byte-compile-cl-functions - (append byte-compile-cl-functions - (cdr elt))))) - (let ((tail byte-compile-cl-functions)) - (while tail - (if (and (consp (car tail)) - (eq (car (car tail)) 'autoload)) - (setcar tail (cdr (car tail)))) - (setq tail (cdr tail)))))) + (string-match + "^cl\\>" (file-name-nondirectory (car elt)))) + (dolist (e (cdr elt)) + (when (memq (car-safe e) '(autoload defun)) + (push (cdr e) byte-compile-cl-functions))))))) (defun byte-compile-cl-warn (form) "Warn if FORM is a call of a function from the CL package." @@ -1415,7 +1476,7 @@ extra args." ;; defined, issue a warning enumerating them. ;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () - (when (memq 'unresolved byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'unresolved) (let ((byte-compile-current-form :end) (noruntime nil) (unresolved nil)) @@ -1478,9 +1539,7 @@ symbol itself." byte-compile-dynamic-docstrings) ;; (byte-compile-generate-emacs19-bytecodes ;; byte-compile-generate-emacs19-bytecodes) - (byte-compile-warnings (if (eq byte-compile-warnings t) - byte-compile-warning-types - byte-compile-warnings)) + (byte-compile-warnings byte-compile-warnings) ) body))) @@ -1522,35 +1581,40 @@ Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") (byte-recompile-directory directory nil t)) +;; The `bytecomp-' prefix is applied to all local variables with +;; otherwise common names in this and similar functions for the sake +;; of the boundp test in byte-compile-variable-ref. +;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html +;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html ;;;###autoload -(defun byte-recompile-directory (directory &optional arg force) - "Recompile every `.el' file in DIRECTORY that needs recompilation. +(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg + bytecomp-force) + "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation. This is if a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of DIRECTORY are processed also. +Files in subdirectories of BYTECOMP-DIRECTORY are processed also. If the `.elc' file does not exist, normally this function *does not* -compile the corresponding `.el' file. However, -if ARG (the prefix argument) is 0, that means do compile all those files. -A nonzero ARG means ask the user, for each such `.el' file, -whether to compile it. - -A nonzero ARG also means ask about each subdirectory before scanning it. - -If the third argument FORCE is non-nil, -recompile every `.el' file that already has a `.elc' file." +compile the corresponding `.el' file. However, if the prefix argument +BYTECOMP-ARG is 0, that means do compile all those files. A nonzero +BYTECOMP-ARG means ask the user, for each such `.el' file, whether to +compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory +before scanning it. + +If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file +that already has a `.elc' file." (interactive "DByte recompile directory: \nP") - (if arg - (setq arg (prefix-numeric-value arg))) + (if bytecomp-arg + (setq bytecomp-arg (prefix-numeric-value bytecomp-arg))) (if noninteractive nil (save-some-buffers) (force-mode-line-update)) (with-current-buffer (get-buffer-create "*Compile-Log*") - (setq default-directory (expand-file-name directory)) + (setq default-directory (expand-file-name bytecomp-directory)) ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) - (let ((directories (list default-directory)) + (let ((bytecomp-directories (list default-directory)) (default-directory default-directory) (skip-count 0) (fail-count 0) @@ -1558,56 +1622,63 @@ recompile every `.el' file that already has a `.elc' file." (dir-count 0) last-dir) (displaying-byte-compile-warnings - (while directories - (setq directory (car directories)) - (message "Checking %s..." directory) - (let ((files (directory-files directory)) - source dest) - (dolist (file files) - (setq source (expand-file-name file directory)) - (if (and (not (member file '("RCS" "CVS"))) - (not (eq ?\. (aref file 0))) - (file-directory-p source) - (not (file-symlink-p source))) + (while bytecomp-directories + (setq bytecomp-directory (car bytecomp-directories)) + (message "Checking %s..." bytecomp-directory) + (let ((bytecomp-files (directory-files bytecomp-directory)) + bytecomp-source bytecomp-dest) + (dolist (bytecomp-file bytecomp-files) + (setq bytecomp-source + (expand-file-name bytecomp-file bytecomp-directory)) + (if (and (not (member bytecomp-file '("RCS" "CVS"))) + (not (eq ?\. (aref bytecomp-file 0))) + (file-directory-p bytecomp-source) + (not (file-symlink-p bytecomp-source))) ;; This file is a subdirectory. Handle them differently. - (when (or (null arg) - (eq 0 arg) - (y-or-n-p (concat "Check " source "? "))) - (setq directories - (nconc directories (list source)))) + (when (or (null bytecomp-arg) + (eq 0 bytecomp-arg) + (y-or-n-p (concat "Check " bytecomp-source "? "))) + (setq bytecomp-directories + (nconc bytecomp-directories (list bytecomp-source)))) ;; It is an ordinary file. Decide whether to compile it. - (if (and (string-match emacs-lisp-file-regexp source) - (file-readable-p source) - (not (auto-save-file-name-p source)) - (setq dest (byte-compile-dest-file source)) - (if (file-exists-p dest) + (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 force (file-newer-than-file-p source dest)) + (or bytecomp-force + (file-newer-than-file-p bytecomp-source + bytecomp-dest)) ;; No compiled file exists yet. - (and arg - (or (eq 0 arg) - (y-or-n-p (concat "Compile " source "? ")))))) + (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..." source)) - (let ((res (byte-compile-file source))) - (cond ((eq res 'no-byte-compile) + (message "Compiling %s..." bytecomp-source)) + (let ((bytecomp-res (byte-compile-file + bytecomp-source))) + (cond ((eq bytecomp-res 'no-byte-compile) (setq skip-count (1+ skip-count))) - ((eq res t) + ((eq bytecomp-res t) (setq file-count (1+ file-count))) - ((eq res nil) + ((eq bytecomp-res nil) (setq fail-count (1+ fail-count))))) (or noninteractive - (message "Checking %s..." directory)) - (if (not (eq last-dir directory)) - (setq last-dir directory + (message "Checking %s..." bytecomp-directory)) + (if (not (eq last-dir bytecomp-directory)) + (setq last-dir bytecomp-directory dir-count (1+ dir-count))) ))))) - (setq directories (cdr directories)))) + (setq bytecomp-directories (cdr bytecomp-directories)))) (message "Done (Total of %d file%s compiled%s%s%s)" file-count (if (= file-count 1) "" "s") (if (> fail-count 0) (format ", %d failed" fail-count) "") (if (> skip-count 0) (format ", %d skipped" skip-count) "") - (if (> dir-count 1) (format " in %d directories" dir-count) ""))))) + (if (> dir-count 1) + (format " in %d directories" dir-count) ""))))) (defvar no-byte-compile nil "Non-nil to prevent byte-compiling of emacs-lisp code. @@ -1617,45 +1688,46 @@ This is normally set in local file variables at the end of the elisp file: ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) ;;;###autoload -(defun byte-compile-file (filename &optional load) - "Compile a file of Lisp code named FILENAME into a file of byte code. -The output file's name is generated by passing FILENAME to the -`byte-compile-dest-file' function (which see). +(defun byte-compile-file (bytecomp-filename &optional load) + "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. +The output file's name is generated by passing BYTECOMP-FILENAME to the +function `byte-compile-dest-file' (which see). With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. The value is non-nil if there were no errors, nil if errors." ;; (interactive "fByte compile file: \nP") (interactive - (let ((file buffer-file-name) - (file-name nil) - (file-dir nil)) - (and file + (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 file-name (file-name-nondirectory file) - file-dir (file-name-directory file))) + (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 and load file: " "Byte compile file: ") - file-dir file-name nil) + bytecomp-file-dir bytecomp-file-name nil) current-prefix-arg))) ;; Expand now so we get the current buffer's defaults - (setq filename (expand-file-name filename)) + (setq bytecomp-filename (expand-file-name bytecomp-filename)) ;; If we're compiling a file that's in a buffer and is modified, offer ;; to save it first. (or noninteractive - (let ((b (get-file-buffer (expand-file-name filename)))) + (let ((b (get-file-buffer (expand-file-name bytecomp-filename)))) (if (and b (buffer-modified-p b) (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) (with-current-buffer b (save-buffer))))) ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file filename) + (let ((byte-compile-current-file bytecomp-filename) + (byte-compile-current-group nil) (set-auto-coding-for-load t) target-file input-buffer output-buffer byte-compile-dest-file) - (setq target-file (byte-compile-dest-file filename)) + (setq target-file (byte-compile-dest-file bytecomp-filename)) (setq byte-compile-dest-file target-file) (with-current-buffer (setq input-buffer (get-buffer-create " *Compiler Input*")) @@ -1664,7 +1736,7 @@ The value is non-nil if there were no errors, nil if errors." ;; Always compile an Emacs Lisp file as multibyte ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- (set-buffer-multibyte t) - (insert-file-contents filename) + (insert-file-contents bytecomp-filename) ;; Mimic the way after-insert-file-set-coding can make the ;; buffer unibyte when visiting this file. (when (or (eq last-coding-system-used 'no-conversion) @@ -1674,7 +1746,7 @@ The value is non-nil if there were no errors, nil if errors." (set-buffer-multibyte nil)) ;; Run hooks including the uncompression hook. ;; If they change the file name, then change it for the output also. - (let ((buffer-file-name filename) + (let ((buffer-file-name bytecomp-filename) (default-major-mode 'emacs-lisp-mode) ;; Ignore unsafe local variables. ;; We only care about a few of them for our purposes. @@ -1682,15 +1754,15 @@ The value is non-nil if there were no errors, nil if errors." (enable-local-eval nil)) ;; Arg of t means don't alter enable-local-variables. (normal-mode t) - (setq filename buffer-file-name)) + (setq bytecomp-filename buffer-file-name)) ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory filename))) + (setq default-directory (file-name-directory bytecomp-filename))) ;; Check if the file's local variables explicitly specify not to ;; compile this file. (if (with-current-buffer input-buffer no-byte-compile) (progn ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (file-relative-name filename) + ;; (file-relative-name bytecomp-filename) ;; (with-current-buffer input-buffer no-byte-compile)) (when (file-exists-p target-file) (message "%s deleted because of `no-byte-compile: %s'" @@ -1700,18 +1772,18 @@ The value is non-nil if there were no errors, nil if errors." ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose - (message "Compiling %s..." filename)) + (message "Compiling %s..." bytecomp-filename)) (setq byte-compiler-error-flag nil) ;; It is important that input-buffer not be current at this call, ;; so that the value of point set in input-buffer ;; within byte-compile-from-buffer lingers in that buffer. (setq output-buffer (save-current-buffer - (byte-compile-from-buffer input-buffer filename))) + (byte-compile-from-buffer input-buffer bytecomp-filename))) (if byte-compiler-error-flag nil (when byte-compile-verbose - (message "Compiling %s...done" filename)) + (message "Compiling %s...done" bytecomp-filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) @@ -1740,9 +1812,10 @@ The value is non-nil if there were no errors, nil if errors." (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " filename)))) + (y-or-n-p (format "Report call tree for %s? " + bytecomp-filename)))) (save-excursion - (display-call-tree filename))) + (display-call-tree bytecomp-filename))) (if load (load target-file)) t)))) @@ -1823,9 +1896,7 @@ With argument, insert value in current buffer after the form." (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. - ;; (byte-compile-warnings (if (eq byte-compile-warnings t) - ;; byte-compile-warning-types - ;; byte-compile-warnings)) + ;; (byte-compile-warnings byte-compile-warnings) ) (byte-compile-close-variables (with-current-buffer @@ -1844,7 +1915,7 @@ With argument, insert value in current buffer after the form." (displaying-byte-compile-warnings (and filename (byte-compile-insert-header filename inbuffer outbuffer)) (with-current-buffer inbuffer - (goto-char 1) + (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been ;; compiled. A: Yes! b-c-u-f might contain dross from a @@ -1900,13 +1971,13 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (delete-region (point) (progn (re-search-forward "^(") (beginning-of-line) (point))) - (insert ";;; This file contains multibyte non-ASCII characters\n" - ";;; and therefore cannot be loaded into Emacs 19.\n") - ;; Replace "19" or "19.29" with "20", twice. + (insert ";;; This file contains utf-8 non-ASCII characters\n" + ";;; and therefore cannot be loaded into Emacs 21 or earlier.\n") + ;; Replace "19" or "19.29" with "22", twice. (re-search-forward "19\\(\\.[0-9]+\\)") - (replace-match "20") + (replace-match "23") (re-search-forward "19\\(\\.[0-9]+\\)") - (replace-match "20") + (replace-match "23") ;; Now compensate for the change in size, ;; to make sure all positions in the file remain valid. (setq delta (- (point-max) old-header-end)) @@ -1915,52 +1986,52 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (delete-char delta))))) (defun byte-compile-insert-header (filename inbuffer outbuffer) - (set-buffer inbuffer) - (let ((dynamic-docstrings byte-compile-dynamic-docstrings) - (dynamic byte-compile-dynamic)) - (set-buffer outbuffer) - (goto-char 1) - ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After - ;; that is the file-format version number (18, 19 or 20) as a - ;; byte, followed by some nulls. The primary motivation for doing - ;; this is to get some binary characters up in the first line of - ;; the file so that `diff' will simply say "Binary files differ" - ;; instead of actually doing a diff of two .elc files. An extra - ;; benefit is that you can add this to /etc/magic: - - ;; 0 string ;ELC GNU Emacs Lisp compiled file, - ;; >4 byte x version %d - - (insert - ";ELC" - (if (byte-compile-version-cond byte-compile-compatibility) 18 20) - "\000\000\000\n" - ) - (insert ";;; Compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "@" (system-name))) - " on " - (current-time-string) "\n;;; from file " filename "\n") - (insert ";;; in Emacs version " emacs-version "\n") - (insert ";;; " - (cond - ((eq byte-optimize 'source) "with source-level optimization only") - ((eq byte-optimize 'byte) "with byte-level optimization only") - (byte-optimize "with all optimizations") - (t "without optimization")) - (if (byte-compile-version-cond byte-compile-compatibility) - "; compiled with Emacs 18 compatibility.\n" - ".\n")) - (if dynamic - (insert ";;; Function definitions are lazy-loaded.\n")) - (if (not (byte-compile-version-cond byte-compile-compatibility)) - (let (intro-string minimum-version) - ;; Figure out which Emacs version to require, - ;; and what comment to use to explain why. - ;; Note that this fails to take account of whether - ;; the buffer contains multibyte characters. We may have to - ;; compensate at the end in byte-compile-fix-header. - (if dynamic-docstrings + (with-current-buffer inbuffer + (let ((dynamic-docstrings byte-compile-dynamic-docstrings) + (dynamic byte-compile-dynamic)) + (set-buffer outbuffer) + (goto-char (point-min)) + ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After + ;; that is the file-format version number (18, 19, 20, or 23) as a + ;; byte, followed by some nulls. The primary motivation for doing + ;; this is to get some binary characters up in the first line of + ;; the file so that `diff' will simply say "Binary files differ" + ;; instead of actually doing a diff of two .elc files. An extra + ;; benefit is that you can add this to /etc/magic: + + ;; 0 string ;ELC GNU Emacs Lisp compiled file, + ;; >4 byte x version %d + + (insert + ";ELC" + (if (byte-compile-version-cond byte-compile-compatibility) 18 23) + "\000\000\000\n" + ) + (insert ";;; Compiled by " + (or (and (boundp 'user-mail-address) user-mail-address) + (concat (user-login-name) "@" (system-name))) + " on " + (current-time-string) "\n;;; from file " filename "\n") + (insert ";;; in Emacs version " emacs-version "\n") + (insert ";;; " + (cond + ((eq byte-optimize 'source) "with source-level optimization only") + ((eq byte-optimize 'byte) "with byte-level optimization only") + (byte-optimize "with all optimizations") + (t "without optimization")) + (if (byte-compile-version-cond byte-compile-compatibility) + "; compiled with Emacs 18 compatibility.\n" + ".\n")) + (if dynamic + (insert ";;; Function definitions are lazy-loaded.\n")) + (if (not (byte-compile-version-cond byte-compile-compatibility)) + (let (intro-string minimum-version) + ;; Figure out which Emacs version to require, + ;; and what comment to use to explain why. + ;; Note that this fails to take account of whether + ;; the buffer contains multibyte characters. We may have to + ;; compensate at the end in byte-compile-fix-header. + (if dynamic-docstrings (setq intro-string ";;; This file uses dynamic docstrings, first added in Emacs 19.29.\n" minimum-version "19.29") @@ -1989,14 +2060,14 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; Insert semicolons as ballast, so that byte-compile-fix-header ;; can delete them so as to keep the buffer positions ;; constant for the actual compiled code. - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")) + ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")) ;; Here if we want Emacs 18 compatibility. (when dynamic-docstrings (error "Version-18 compatibility doesn't support dynamic doc strings")) (when byte-compile-dynamic (error "Version-18 compatibility doesn't support dynamic byte code")) (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" - "\n")))) + "\n"))))) (defun byte-compile-output-file-form (form) ;; writes the given form to the output buffer, being careful of docstrings @@ -2038,86 +2109,83 @@ list that represents a doc string reference. ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - ;; FIXME: What's up with those set-buffers&prog1 thingy? --Stef - (set-buffer - (prog1 (current-buffer) - (set-buffer outbuffer) - (let (position) - - ;; Insert the doc string, and make it a comment with #@LENGTH. - (and (>= (nth 1 info) 0) - dynamic-docstrings - (not byte-compile-compatibility) - (progn - ;; Make the doc string start at beginning of line - ;; for make-docfile's sake. - (insert "\n") - (setq position - (byte-compile-output-as-comment - (nth (nth 1 info) form) nil)) - (setq position (- (position-bytes position) (point-min) -1)) - ;; If the doc string starts with * (a user variable), - ;; negate POSITION. - (if (and (stringp (nth (nth 1 info) form)) - (> (length (nth (nth 1 info) form)) 0) - (eq (aref (nth (nth 1 info) form) 0) ?*)) - (setq position (- position))))) - - (if preface - (progn - (insert preface) - (prin1 name outbuffer))) - (insert (car info)) - (let ((print-escape-newlines t) - (print-quoted t) - ;; For compatibility with code before print-circle, - ;; use a cons cell to say that we want - ;; print-gensym-alist not to be cleared - ;; between calls to print functions. - (print-gensym '(t)) - (print-circle ; handle circular data structures - (not byte-compile-disable-print-circle)) - print-gensym-alist ; was used before print-circle existed. - (print-continuous-numbering t) - print-number-table - (index 0)) - (prin1 (car form) outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex) - ;; Don't handle the definition dynamically - ;; if it refers (or might refer) - ;; to objects already output - ;; (for instance, gensyms in the arg list). - (let (non-nil) - (dotimes (i (length print-number-table)) - (if (aref print-number-table i) - (setq non-nil t))) - (not non-nil))) - ;; Output the byte code and constants specially - ;; for lazy dynamic loading. - (let ((position - (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (setq position (- (position-bytes position) (point-min) -1)) - (princ (format "(#$ . %d) nil" position) outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((= index (nth 1 info)) - (if position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - position) - outbuffer) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) outbuffer))) - (insert "\\\n") - (goto-char (point-max))))) - (t - (prin1 (car form) outbuffer))))) - (insert (nth 2 info)))))) + (with-current-buffer outbuffer + (let (position) + + ;; Insert the doc string, and make it a comment with #@LENGTH. + (and (>= (nth 1 info) 0) + dynamic-docstrings + (not byte-compile-compatibility) + (progn + ;; Make the doc string start at beginning of line + ;; for make-docfile's sake. + (insert "\n") + (setq position + (byte-compile-output-as-comment + (nth (nth 1 info) form) nil)) + (setq position (- (position-bytes position) (point-min) -1)) + ;; If the doc string starts with * (a user variable), + ;; negate POSITION. + (if (and (stringp (nth (nth 1 info) form)) + (> (length (nth (nth 1 info) form)) 0) + (eq (aref (nth (nth 1 info) form) 0) ?*)) + (setq position (- position))))) + + (if preface + (progn + (insert preface) + (prin1 name outbuffer))) + (insert (car info)) + (let ((print-escape-newlines t) + (print-quoted t) + ;; For compatibility with code before print-circle, + ;; use a cons cell to say that we want + ;; print-gensym-alist not to be cleared + ;; between calls to print functions. + (print-gensym '(t)) + (print-circle ; handle circular data structures + (not byte-compile-disable-print-circle)) + print-gensym-alist ; was used before print-circle existed. + (print-continuous-numbering t) + print-number-table + (index 0)) + (prin1 (car form) outbuffer) + (while (setq form (cdr form)) + (setq index (1+ index)) + (insert " ") + (cond ((and (numberp specindex) (= index specindex) + ;; Don't handle the definition dynamically + ;; if it refers (or might refer) + ;; to objects already output + ;; (for instance, gensyms in the arg list). + (let (non-nil) + (dotimes (i (length print-number-table)) + (if (aref print-number-table i) + (setq non-nil t))) + (not non-nil))) + ;; Output the byte code and constants specially + ;; for lazy dynamic loading. + (let ((position + (byte-compile-output-as-comment + (cons (car form) (nth 1 form)) + t))) + (setq position (- (position-bytes position) (point-min) -1)) + (princ (format "(#$ . %d) nil" position) outbuffer) + (setq form (cdr form)) + (setq index (1+ index)))) + ((= index (nth 1 info)) + (if position + (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") + position) + outbuffer) + (let ((print-escape-newlines nil)) + (goto-char (prog1 (1+ (point)) + (prin1 (car form) outbuffer))) + (insert "\\\n") + (goto-char (point-max))))) + (t + (prin1 (car form) outbuffer))))) + (insert (nth 2 info))))) nil) (defun byte-compile-keep-pending (form &optional handler) @@ -2207,7 +2275,7 @@ 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 (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push (nth 1 form) byte-compile-bound-variables) (if (eq (car form) 'defconst) (push (nth 1 form) byte-compile-const-variables))) @@ -2217,37 +2285,41 @@ list that represents a doc string reference. (byte-compile-top-level (nth 2 form) nil 'file)))) form)) +(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) +(defun byte-compile-file-form-define-abbrev-table (form) + (when (and (byte-compile-warning-enabled-p 'free-vars) + (eq 'quote (car-safe (car-safe (cdr form))))) + (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) + (byte-compile-keep-pending form)) + (put 'custom-declare-variable 'byte-hunk-handler 'byte-compile-file-form-custom-declare-variable) (defun byte-compile-file-form-custom-declare-variable (form) - (when (memq 'callargs byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (when (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push (nth 1 (nth 1 form)) byte-compile-bound-variables)) + ;; Don't compile the expression because it may be displayed to the user. + ;; (when (eq (car-safe (nth 2 form)) 'quote) + ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the + ;; ;; final value already, we can byte-compile it. + ;; (setcar (cdr (nth 2 form)) + ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file))) (let ((tail (nthcdr 4 form))) (while tail - ;; If there are any (function (lambda ...)) expressions, compile - ;; those functions. - (if (and (consp (car tail)) - (eq (car (car tail)) 'function) - (consp (nth 1 (car tail)))) - (setcar tail (byte-compile-lambda (nth 1 (car tail)))) - ;; Likewise for a bare lambda. - (if (and (consp (car tail)) - (eq (car (car tail)) 'lambda)) - (setcar tail (byte-compile-lambda (car tail))))) + (unless (keywordp (car tail)) ;No point optimizing keywords. + ;; Compile the keyword arguments. + (setcar tail (byte-compile-top-level (car tail) nil 'file))) (setq tail (cdr tail)))) form) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let ((old-load-list current-load-list) - (args (mapcar 'eval (cdr form)))) + (let ((args (mapcar 'eval (cdr form)))) (apply 'require args) ;; Detect (require 'cl) in a way that works even if cl is already loaded. (if (member (car args) '("cl" cl)) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings)))) + (byte-compile-disable-warning 'cl-functions))) (byte-compile-keep-pending form 'byte-compile-normal-call)) (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) @@ -2293,12 +2365,12 @@ list that represents a doc string reference. (cons (list name nil nil) byte-compile-call-tree)))) (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'redefine) (byte-compile-arglist-warn form macrop)) (if byte-compile-verbose (message "Compiling %s... (%s)" (or filename "") (nth 1 form))) (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) + (if (and (byte-compile-warning-enabled-p 'redefine) ;; don't warn when compiling the stubs in byte-run... (not (assq (nth 1 form) byte-compile-initial-macro-environment))) @@ -2307,7 +2379,7 @@ list that represents a doc string reference. (nth 1 form))) (setcdr that-one nil)) (this-one - (when (and (memq 'redefine byte-compile-warnings) + (when (and (byte-compile-warning-enabled-p 'redefine) ;; hack: don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... (not (assq (nth 1 form) @@ -2318,7 +2390,7 @@ list that represents a doc string reference. ((and (fboundp name) (eq (car-safe (symbol-function name)) (if macrop 'lambda 'macro))) - (when (memq 'redefine byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'redefine) (byte-compile-warn "%s `%s' being redefined as a %s" (if macrop "function" "macro") (nth 1 form) @@ -2404,39 +2476,37 @@ list that represents a doc string reference. ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. (defun byte-compile-output-as-comment (exp quoted) (let ((position (point))) - (set-buffer - (prog1 (current-buffer) - (set-buffer outbuffer) - - ;; Insert EXP, and make it a comment with #@LENGTH. - (insert " ") - (if quoted - (prin1 exp outbuffer) - (princ exp outbuffer)) - (goto-char position) - ;; Quote certain special characters as needed. - ;; get_doc_string in doc.c does the unquoting. - (while (search-forward "\^A" nil t) - (replace-match "\^A\^A" t t)) - (goto-char position) - (while (search-forward "\000" nil t) - (replace-match "\^A0" t t)) - (goto-char position) - (while (search-forward "\037" nil t) - (replace-match "\^A_" t t)) - (goto-char (point-max)) - (insert "\037") - (goto-char position) - (insert "#@" (format "%d" (- (position-bytes (point-max)) - (position-bytes position)))) - - ;; Save the file position of the object. - ;; Note we should add 1 to skip the space - ;; that we inserted before the actual doc string, - ;; and subtract 1 to convert from an 1-origin Emacs position - ;; to a file position; they cancel. - (setq position (point)) - (goto-char (point-max)))) + (with-current-buffer outbuffer + + ;; Insert EXP, and make it a comment with #@LENGTH. + (insert " ") + (if quoted + (prin1 exp outbuffer) + (princ exp outbuffer)) + (goto-char position) + ;; Quote certain special characters as needed. + ;; get_doc_string in doc.c does the unquoting. + (while (search-forward "\^A" nil t) + (replace-match "\^A\^A" t t)) + (goto-char position) + (while (search-forward "\000" nil t) + (replace-match "\^A0" t t)) + (goto-char position) + (while (search-forward "\037" nil t) + (replace-match "\^A_" t t)) + (goto-char (point-max)) + (insert "\037") + (goto-char position) + (insert "#@" (format "%d" (- (position-bytes (point-max)) + (position-bytes position)))) + + ;; Save the file position of the object. + ;; Note we should add 1 to skip the space + ;; that we inserted before the actual doc string, + ;; and subtract 1 to convert from an 1-origin Emacs position + ;; to a file position; they cancel. + (setq position (point)) + (goto-char (point-max))) position)) @@ -2560,7 +2630,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables - (nconc (and (memq 'free-vars byte-compile-warnings) + (nconc (and (byte-compile-warning-enabled-p 'free-vars) (delq '&rest (delq '&optional (copy-sequence arglist)))) byte-compile-bound-variables)) (body (cdr (cdr fun))) @@ -2771,6 +2841,20 @@ If FORM is a lambda or a macro, byte-compile it as a function." (cdr body)) (body (list body)))) + +(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) +(defun byte-compile-declare-function (form) + (push (cons (nth 1 form) + (if (and (> (length form) 3) + (listp (nth 3 form))) + (list 'declared (nth 3 form)) + t)) ; arglist not specified + byte-compile-function-environment) + ;; We are stating that it _will_ be defined at runtime. + (setq byte-compile-noruntime-functions + (delq (nth 1 form) byte-compile-noruntime-functions)) + nil) + ;; This is the recursive entry point for compiling each subform of an ;; expression. @@ -2800,7 +2884,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (handler (get fn 'byte-compile))) (when (byte-compile-const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) - (and (memq 'interactive-only byte-compile-warnings) + (and (byte-compile-warning-enabled-p 'interactive-only) (memq fn byte-compile-interactive-only-functions) (byte-compile-warn "`%s' used from Lisp code\n\ That command is designed for interactive use only" fn)) @@ -2815,12 +2899,12 @@ That command is designed for interactive use only" fn)) byte-compile-compatibility) (get (get fn 'byte-opcode) 'emacs19-opcode)))) (funcall handler form) - (when (memq 'callargs byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'callargs) (if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (byte-compile-normal-call form)) - (if (memq 'cl-functions byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'cl-functions) (byte-compile-cl-warn form)))) ((and (or (byte-code-function-p (car form)) (eq (car-safe (car form)) 'lambda)) @@ -2836,6 +2920,11 @@ That command is designed for interactive use only" fn)) (defun byte-compile-normal-call (form) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) + (when (and for-effect (eq (car form) 'mapcar) + (byte-compile-warning-enabled-p 'mapcar)) + (byte-compile-set-symbol-position 'mapcar) + (byte-compile-warn + "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) @@ -2851,17 +2940,10 @@ That command is designed for interactive use only" fn)) (t "variable reference to %s `%s'")) (if (symbolp var) "constant" "nonvariable") (prin1-to-string var)) - (if (and (get var 'byte-obsolete-variable) - (memq 'obsolete byte-compile-warnings) - (not (eq var byte-compile-not-obsolete-var))) - (let* ((ob (get var 'byte-obsolete-variable)) - (when (cdr ob))) - (byte-compile-warn "`%s' is an obsolete variable%s; %s" var - (if when (concat " (as of Emacs " when ")") "") - (if (stringp (car ob)) - (car ob) - (format "use `%s' instead." (car ob)))))) - (if (memq 'free-vars byte-compile-warnings) + (and (get var 'byte-obsolete-variable) + (not (eq var byte-compile-not-obsolete-var)) + (byte-compile-warn-obsolete var)) + (if (byte-compile-warning-enabled-p 'free-vars) (if (eq base-op 'byte-varbind) (push var byte-compile-bound-variables) (or (boundp var) @@ -3418,6 +3500,8 @@ That command is designed for interactive use only" fn)) (byte-defop-compiler-1 mapc byte-compile-funarg) (byte-defop-compiler-1 maphash byte-compile-funarg) (byte-defop-compiler-1 map-char-table byte-compile-funarg) +(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) +;; map-charset-chars should be funarg but has optional third arg (byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) (byte-defop-compiler-1 let*) @@ -3441,46 +3525,61 @@ That command is designed for interactive use only" fn)) (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) ,tag)) +;; Return the list of items in CONDITION-PARAM that match PRED-LIST. +;; Only return items that are not in ONLY-IF-NOT-PRESENT. +(defun byte-compile-find-bound-condition (condition-param + pred-list + &optional only-if-not-present) + (let ((result nil) + (nth-one nil) + (cond-list + (if (memq (car-safe condition-param) pred-list) + ;; The condition appears by itself. + (list condition-param) + ;; If the condition is an `and', look for matches among the + ;; `and' arguments. + (when (eq 'and (car-safe condition-param)) + (cdr condition-param))))) + + (dolist (crt cond-list) + (when (and (memq (car-safe crt) pred-list) + (eq 'quote (car-safe (setq nth-one (nth 1 crt)))) + ;; Ignore if the symbol is already on the unresolved + ;; list. + (not (assq (nth 1 nth-one) ; the relevant symbol + only-if-not-present))) + (push (nth 1 (nth 1 crt)) result))) + result)) + (defmacro byte-compile-maybe-guarded (condition &rest body) "Execute forms in BODY, potentially guarded by CONDITION. CONDITION is a variable whose value is a test in an `if' or `cond'. -BODY is the code to compile first arm of the if or the body of the -cond clause. If CONDITION's value is of the form (fboundp 'foo) +BODY is the code to compile in the first arm of the if or the body of +the cond clause. If CONDITION's value is of the form (fboundp 'foo) or (boundp 'foo), the relevant warnings from BODY about foo's being undefined will be suppressed. If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) - `(let* ((fbound - (if (eq 'fboundp (car-safe ,condition)) - (and (eq 'quote (car-safe (nth 1 ,condition))) - ;; Ignore if the symbol is already on the - ;; unresolved list. - (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol - byte-compile-unresolved-functions)) - (nth 1 (nth 1 ,condition))))) - (bound (if (or (eq 'boundp (car-safe ,condition)) - (eq 'default-boundp (car-safe ,condition))) - (and (eq 'quote (car-safe (nth 1 ,condition))) - (nth 1 (nth 1 ,condition))))) + `(let* ((fbound-list (byte-compile-find-bound-condition + ,condition (list 'fboundp) + byte-compile-unresolved-functions)) + (bound-list (byte-compile-find-bound-condition + ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound - (cons bound byte-compile-bound-variables) - byte-compile-bound-variables)) - ;; Suppress all warnings, for code not used in Emacs. - (byte-compile-warnings - (if (member ,condition '((featurep 'xemacs) - (not (featurep 'emacs)))) - nil byte-compile-warnings))) + (if bound-list + (append bound-list byte-compile-bound-variables) + byte-compile-bound-variables))) (unwind-protect (progn ,@body) ;; Maybe remove the function symbol from the unresolved list. - (if fbound + (dolist (fbound fbound-list) + (when fbound (setq byte-compile-unresolved-functions (delq (assq fbound byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))))) + byte-compile-unresolved-functions))))))) (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) @@ -3802,7 +3901,7 @@ that suppresses all warnings during execution of BODY." (if (= 1 ncall) "" "s") (if (< ncall 2) "requires" "accepts only") "2-3"))) - (when (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push var byte-compile-bound-variables) (if (eq fun 'defconst) (push var byte-compile-const-variables))) @@ -3893,7 +3992,8 @@ that suppresses all warnings during execution of BODY." ;; Warn about misuses of make-variable-buffer-local. (byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local) (defun byte-compile-make-variable-buffer-local (form) - (if (eq (car-safe (car-safe (cdr-safe form))) 'quote) + (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) + (byte-compile-warning-enabled-p 'make-local)) (byte-compile-warn "`make-variable-buffer-local' should be called at toplevel")) (byte-compile-normal-call form)) @@ -4130,50 +4230,52 @@ already up-to-date." (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) ;; Directory as argument. - (let ((files (directory-files (car command-line-args-left))) - source dest) - (dolist (file files) - (if (and (string-match emacs-lisp-file-regexp file) - (not (auto-save-file-name-p file)) - (setq source (expand-file-name file - (car command-line-args-left))) - (setq dest (byte-compile-dest-file source)) - (file-exists-p dest) - (file-newer-than-file-p source dest)) - (if (null (batch-byte-compile-file source)) + (let ((bytecomp-files (directory-files (car command-line-args-left))) + bytecomp-source bytecomp-dest) + (dolist (bytecomp-file bytecomp-files) + (if (and (string-match emacs-lisp-file-regexp bytecomp-file) + (not (auto-save-file-name-p bytecomp-file)) + (setq bytecomp-source + (expand-file-name bytecomp-file + (car command-line-args-left))) + (setq bytecomp-dest (byte-compile-dest-file + bytecomp-source)) + (file-exists-p bytecomp-dest) + (file-newer-than-file-p bytecomp-source bytecomp-dest)) + (if (null (batch-byte-compile-file bytecomp-source)) (setq error t))))) ;; Specific file argument (if (or (not noforce) - (let* ((source (car command-line-args-left)) - (dest (byte-compile-dest-file source))) - (or (not (file-exists-p dest)) - (file-newer-than-file-p source dest)))) + (let* ((bytecomp-source (car command-line-args-left)) + (bytecomp-dest (byte-compile-dest-file bytecomp-source))) + (or (not (file-exists-p bytecomp-dest)) + (file-newer-than-file-p bytecomp-source bytecomp-dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) (kill-emacs (if error 1 0)))) -(defun batch-byte-compile-file (file) +(defun batch-byte-compile-file (bytecomp-file) (if debug-on-error - (byte-compile-file file) + (byte-compile-file bytecomp-file) (condition-case err - (byte-compile-file file) + (byte-compile-file bytecomp-file) (file-error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - file + bytecomp-file (get (car err) 'error-message) (prin1-to-string (cdr err))) - (let ((destfile (byte-compile-dest-file file))) - (if (file-exists-p destfile) - (delete-file destfile))) + (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) + (if (file-exists-p bytecomp-destfile) + (delete-file bytecomp-destfile))) nil) (error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - file + bytecomp-file (get (car err) 'error-message) (prin1-to-string (cdr err))) nil)))) @@ -4238,18 +4340,18 @@ and corresponding effects." (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) - (mapcar (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-compile-normal-call - byte-compile-form - byte-compile-body - ;; Inserted some more than necessary, to speed it up. - byte-compile-top-level - byte-compile-out-toplevel - byte-compile-constant - byte-compile-variable-ref)))) + (mapc (lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-compile-normal-call + byte-compile-form + byte-compile-body + ;; Inserted some more than necessary, to speed it up. + byte-compile-top-level + byte-compile-out-toplevel + byte-compile-constant + byte-compile-variable-ref)))) nil) (run-hooks 'bytecomp-load-hook) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el new file mode 100644 index 00000000000..5a507178777 --- /dev/null +++ b/lisp/emacs-lisp/check-declare.el @@ -0,0 +1,314 @@ +;;; check-declare.el --- Check declare-function statements + +;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. + +;; Author: Glenn Morris <rgm@gnu.org> +;; Keywords: lisp, tools, maint + +;; 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: + +;; The byte-compiler often warns about undefined functions that you +;; know will actually be defined when it matters. The `declare-function' +;; statement allows you to suppress these warnings. This package +;; checks that all such statements in a file or directory are accurate. +;; The entry points are `check-declare-file' and `check-declare-directory'. + +;; For more information, see Info node `elisp(Declaring Functions)'. + +;;; TODO: + +;; 1. Warn about functions marked as obsolete, eg +;; password-read-and-add in smime.el. + +;;; Code: + +(defconst check-declare-warning-buffer "*Check Declarations Warnings*" + "Name of buffer used to display any `check-declare' warnings.") + +(defun check-declare-locate (file basefile) + "Return the full path of FILE. +Expands files with a \".c\" or \".m\" extension relative to the Emacs +\"src/\" directory. Otherwise, `locate-library' searches for FILE. +If that fails, expands FILE relative to BASEFILE's directory part. +The returned file might not exist. If FILE has an \"ext:\" prefix, so does +the result." + (let ((ext (string-match "^ext:" file)) + tfile) + (if ext + (setq file (substring file 4))) + (setq file + (if (member (file-name-extension file) '("c" "m")) + (expand-file-name file (expand-file-name "src" source-directory)) + (if (setq tfile (locate-library (file-name-nondirectory file))) + (progn + (setq tfile + (replace-regexp-in-string "\\.elc\\'" ".el" tfile)) + (if (and (not (file-exists-p tfile)) + (file-exists-p (concat tfile ".gz"))) + (concat tfile ".gz") + tfile)) + (setq tfile (expand-file-name file + (file-name-directory basefile))) + (if (or (file-exists-p tfile) + (string-match "\\.el\\'" tfile)) + tfile + (concat tfile ".el"))))) + (if ext (concat "ext:" file) + file))) + +(defun check-declare-scan (file) + "Scan FILE for `declare-function' calls. +Return a list with elements of the form (FNFILE FN ARGLIST FILEONLY), +where only the first two elements need be present. This claims that FNFILE +defines FN, with ARGLIST. FILEONLY non-nil means only check that FNFILE +exists, not that it defines FN. This is for function definitions that we +don't know how to recognize (e.g. some macros)." + (let ((m (format "Scanning %s..." file)) + alist fnfile fn arglist fileonly) + (message "%s" m) + (with-temp-buffer + (insert-file-contents file) + (while (re-search-forward + "^[ \t]*(declare-function[ \t]+\\(\\S-+\\)[ \t]+\ +\"\\(\\S-+\\)\"" nil t) + (setq fn (match-string 1) + fnfile (match-string 2) + fnfile (check-declare-locate fnfile (expand-file-name file)) + arglist (progn + (skip-chars-forward " \t\n") + ;; Use `t' to distinguish no arglist + ;; specified from an empty one. + (if (looking-at "\\((\\|nil\\|t\\)") + (read (current-buffer)) + t)) + fileonly (progn + (skip-chars-forward " \t\n") + (if (looking-at "\\(t\\|'\\sw+\\)") + (match-string 1))) + alist (cons (list fnfile fn arglist fileonly) alist)))) + (message "%sdone" m) + alist)) + +(defun check-declare-errmsg (errlist &optional full) + "Return a string with the number of errors in ERRLIST, if any. +Normally just counts the number of elements in ERRLIST. +With optional argument FULL, sums the number of elements in each element." + (if errlist + (let ((l (length errlist))) + (when full + (setq l 0) + (dolist (e errlist) + (setq l (+ l (1- (length e)))))) + (format "%d problem%s found" l (if (= l 1) "" "s"))) + "OK")) + +(autoload 'byte-compile-arglist-signature "bytecomp") + +(defun check-declare-verify (fnfile fnlist) + "Check that FNFILE contains function definitions matching FNLIST. +Each element of FNLIST has the form (FILE FN ARGLIST FILEONLY), where +only the first two elements need be present. This means FILE claimed FN +was defined in FNFILE with the specified ARGLIST. FILEONLY non-nil means +to only check that FNFILE exists, not that it actually defines FN. + +Returns nil if all claims are found to be true, otherwise a list +of errors with elements of the form \(FILE FN TYPE), where TYPE +is a string giving details of the error." + (let ((m (format "Checking %s..." fnfile)) + (cflag (member (file-name-extension fnfile) '("c" "m"))) + (ext (string-match "^ext:" fnfile)) + re fn sig siglist arglist type errlist minargs maxargs) + (message "%s" m) + (if ext + (setq fnfile (substring fnfile 4))) + (if (file-exists-p fnfile) + (with-temp-buffer + (insert-file-contents fnfile) + ;; defsubst's don't _have_ to be known at compile time. + (setq re (format (if cflag + "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" + "^[ \t]*(\\(fset[ \t]+'\\|\ +def\\(?:un\\|subst\\|foo\\|\ +ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\ +\\|\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\)\\)\ +\[ \t]*%s\\([ \t;]+\\|$\\)") + (regexp-opt (mapcar 'cadr fnlist) t))) + (while (re-search-forward re nil t) + (skip-chars-forward " \t\n") + (setq fn (match-string 2) + type (match-string 1) + ;; (min . max) for a fixed number of arguments, or + ;; arglists with optional elements. + ;; (min) for arglists with &rest. + ;; sig = 'err means we could not find an arglist. + sig (cond (cflag + (or + (when (re-search-forward "," nil t 3) + (skip-chars-forward " \t\n") + ;; Assuming minargs and maxargs on same line. + (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ +\\([0-9]+\\|MANY\\|UNEVALLED\\)") + (setq minargs (string-to-number + (match-string 1)) + maxargs (match-string 2)) + (cons minargs (unless (string-match "[^0-9]" + maxargs) + (string-to-number + maxargs))))) + 'err)) + ((string-match + "\\`define-\\(derived\\|generic\\)-mode\\'" + type) + '(0 . 0)) + ((string-match + "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" + type) + '(0 . 1)) + ;; Prompt to update. + ((string-match + "\\`define-obsolete-function-alias\\>" + type) + 'obsolete) + ;; Can't easily check arguments in these cases. + ((string-match "\\`\\(defalias\\|fset\\)\\>" type) + t) + ((looking-at "\\((\\|nil\\)") + (byte-compile-arglist-signature + (read (current-buffer)))) + (t + 'err)) + ;; alist of functions and arglist signatures. + siglist (cons (cons fn sig) siglist))))) + (dolist (e fnlist) + (setq arglist (nth 2 e) + type + (if (not re) + "file not found" + (if (not (setq sig (assoc (cadr e) siglist))) + (unless (nth 3 e) ; fileonly + "function not found") + (setq sig (cdr sig)) + (cond ((eq sig 'obsolete) ; check even when no arglist specified + "obsolete alias") + ;; arglist t means no arglist specified, as + ;; opposed to an empty arglist. + ((eq arglist t) nil) + ((eq sig t) nil) ; eg defalias - can't check arguments + ((eq sig 'err) + "arglist not found") ; internal error + ((not (equal (byte-compile-arglist-signature + arglist) + sig)) + "arglist mismatch"))))) + (when type + (setq errlist (cons (list (car e) (cadr e) type) errlist)))) + (message "%s%s" m + (if (or re (not ext)) + (check-declare-errmsg errlist) + (progn + (setq errlist nil) + "skipping external file"))) + errlist)) + +(defun check-declare-sort (alist) + "Sort a list with elements FILE (FNFILE ...). +Returned list has elements FNFILE (FILE ...)." + (let (file fnfile rest sort a) + (dolist (e alist) + (setq file (car e)) + (dolist (f (cdr e)) + (setq fnfile (car f) + rest (cdr f)) + (if (setq a (assoc fnfile sort)) + (setcdr a (append (cdr a) (list (cons file rest)))) + (setq sort (cons (list fnfile (cons file rest)) sort))))) + sort)) + +(defun check-declare-warn (file fn fnfile type) + "Warn that FILE made a false claim about FN in FNFILE. +TYPE is a string giving the nature of the error. Warning is displayed in +`check-declare-warning-buffer'." + (display-warning 'check-declare + (format "%s said `%s' was defined in %s: %s" + (file-name-nondirectory file) fn + (file-name-nondirectory fnfile) + type) + nil check-declare-warning-buffer)) + +(defun check-declare-files (&rest files) + "Check veracity of all `declare-function' statements in FILES. +Return a list of any errors found." + (let (alist err errlist) + (dolist (file files) + (setq alist (cons (cons file (check-declare-scan file)) alist))) + ;; Sort so that things are ordered by the files supposed to + ;; contain the defuns. + (dolist (e (check-declare-sort alist)) + (if (setq err (check-declare-verify (car e) (cdr e))) + (setq errlist (cons (cons (car e) err) errlist)))) + (if (get-buffer check-declare-warning-buffer) + (kill-buffer check-declare-warning-buffer)) + ;; Sort back again so that errors are ordered by the files + ;; containing the declare-function statements. + (dolist (e (check-declare-sort errlist)) + (dolist (f (cdr e)) + (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + errlist)) + +;;;###autoload +(defun check-declare-file (file) + "Check veracity of all `declare-function' statements in FILE. +See `check-declare-directory' for more information." + (interactive "fFile to check: ") + (or (file-exists-p file) + (error "File `%s' not found" file)) + (let ((m (format "Checking %s..." file)) + errlist) + (message "%s" m) + (setq errlist (check-declare-files file)) + (message "%s%s" m (check-declare-errmsg errlist)) + errlist)) + +;;;###autoload +(defun check-declare-directory (root) + "Check veracity of all `declare-function' statements under directory ROOT. +Returns non-nil if any false statements are found. For this to +work correctly, the statements must adhere to the format +described in the documentation of `declare-function'." + (interactive "DDirectory to check: ") + (or (file-directory-p (setq root (expand-file-name root))) + (error "Directory `%s' not found" root)) + (let ((m "Checking `declare-function' statements...") + (m2 "Finding files with declarations...") + errlist files) + (message "%s" m) + (message "%s" m2) + (setq files (process-lines find-program root + "-name" "*.el" + "-exec" grep-program + "-l" "^[ \t]*(declare-function" "{}" ";")) + (message "%s%d found" m2 (length files)) + (when files + (setq errlist (apply 'check-declare-files files)) + (message "%s%s" m (check-declare-errmsg errlist t)) + errlist))) + +(provide 'check-declare) + +;; arch-tag: a4d6cdc4-deb7-4502-b327-0e4ef3d82d96 +;;; check-declare.el ends here. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index bc79df485b6..dc3bbe9a7cf 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; @@ -175,21 +173,6 @@ (defvar checkdoc-version "0.6.1" "Release version of checkdoc you are currently running.") -;; From custom web page for compatibility between versions of custom: -(eval-and-compile - (condition-case () - (require 'custom) - (error nil)) - (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) - nil ;; We've got what we needed - ;; We have the old custom-library, hack around it! - (defmacro defgroup (&rest args) - nil) - (defmacro custom-add-option (&rest args) - nil) - (defmacro defcustom (var value doc &rest args) - `(defvar ,var ,value ,doc)))) - (defvar compilation-error-regexp-alist) (defvar compilation-mode-font-lock-keywords) @@ -199,6 +182,12 @@ :group 'lisp :version "20.3") +(defcustom checkdoc-minor-mode-string " CDoc" + "*String to display in mode line when Checkdoc mode is enabled; nil for none." + :type '(choice string (const :tag "None" nil)) + :group 'checkdoc + :version "23.1") + (defcustom checkdoc-autofix-flag 'semiautomatic "Non-nil means attempt auto-fixing of doc strings. If this value is the symbol `query', then the user is queried before @@ -227,7 +216,7 @@ and that it's good but not required practice to make non user visible items have doc strings." :group 'checkdoc :type 'boolean) -(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) (defcustom checkdoc-force-history-flag t "Non-nil means that files should have a History section or ChangeLog file. @@ -243,7 +232,7 @@ should be used when the first part could stand alone as a sentence, but it indicates that a modifying clause follows." :group 'checkdoc :type 'boolean) -(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) (defcustom checkdoc-spellcheck-documentation-flag nil "Non-nil means run Ispell on text based on value. @@ -972,7 +961,7 @@ Optional argument INTERACT permits more interactive fixing." (if (not (interactive-p)) e (if e - (message (checkdoc-error-text e)) + (message "%s" (checkdoc-error-text e)) (checkdoc-show-diagnostics) (message "Space Check: done."))))) @@ -1032,15 +1021,15 @@ space at the end of each line." (end (save-excursion (end-of-defun) (point))) (msg (checkdoc-this-string-valid))) (if msg (if no-error - (message (checkdoc-error-text msg)) + (message "%s" (checkdoc-error-text msg)) (error "%s" (checkdoc-error-text msg))) (setq msg (checkdoc-message-text-search beg end)) (if msg (if no-error - (message (checkdoc-error-text msg)) + (message "%s" (checkdoc-error-text msg)) (error "%s" (checkdoc-error-text msg))) (setq msg (checkdoc-rogue-space-check-engine beg end)) (if msg (if no-error - (message (checkdoc-error-text msg)) + (message "%s" (checkdoc-error-text msg)) (error "%s" (checkdoc-error-text msg)))))) (if (interactive-p) (message "Checkdoc: done.")))))) @@ -1176,7 +1165,7 @@ generating a buffered list of errors." ;; Override some bindings (define-key map "\C-\M-x" 'checkdoc-eval-defun) (define-key map "\C-x`" 'checkdoc-continue) - (if (not (string-match "XEmacs" emacs-version)) + (if (not (featurep 'xemacs)) (define-key map [menu-bar emacs-lisp eval-buffer] 'checkdoc-eval-current-buffer)) ;; Add some new bindings under C-c ? @@ -1202,9 +1191,8 @@ generating a buffered list of errors." map) "Keymap used to override evaluation key-bindings for documentation checking.") -(defvaralias 'checkdoc-minor-keymap 'checkdoc-minor-mode-map) -(make-obsolete-variable 'checkdoc-minor-keymap - 'checkdoc-minor-mode-map) +(define-obsolete-variable-alias 'checkdoc-minor-keymap + 'checkdoc-minor-mode-map "21.1") ;; Add in a menubar with easy-menu @@ -1251,7 +1239,7 @@ bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c checking of documentation strings. \\{checkdoc-minor-mode-map}" - nil " CDoc" nil + nil checkdoc-minor-mode-string nil :group 'checkdoc) ;;; Subst utils @@ -1648,25 +1636,28 @@ function,command,variable,option or symbol." ms1)))))) (checkdoc-create-error "Flag variable doc strings should usually start: Non-nil means" s (marker-position e) t)) + ;; Don't rename variable to "foo-flag". This is unnecessary + ;; and such names often end up inconvenient when the variable + ;; is later expanded to non-boolean values. --Stef ;; If the doc string starts with "Non-nil means" - (if (and (looking-at "\"\\*?Non-nil\\s-+means\\s-+") - (not (string-match "-flag$" (car fp)))) - (let ((newname - (if (string-match "-p$" (car fp)) - (concat (substring (car fp) 0 -2) "-flag") - (concat (car fp) "-flag")))) - (if (checkdoc-y-or-n-p - (format - "Rename to %s and Query-Replace all occurrences? " - newname)) - (progn - (beginning-of-defun) - (query-replace-regexp - (concat "\\<" (regexp-quote (car fp)) "\\>") - newname)) - (checkdoc-create-error - "Flag variable names should normally end in `-flag'" s - (marker-position e))))) + ;; (if (and (looking-at "\"\\*?Non-nil\\s-+means\\s-+") + ;; (not (string-match "-flag$" (car fp)))) + ;; (let ((newname + ;; (if (string-match "-p$" (car fp)) + ;; (concat (substring (car fp) 0 -2) "-flag") + ;; (concat (car fp) "-flag")))) + ;; (if (checkdoc-y-or-n-p + ;; (format + ;; "Rename to %s and Query-Replace all occurrences? " + ;; newname)) + ;; (progn + ;; (beginning-of-defun) + ;; (query-replace-regexp + ;; (concat "\\<" (regexp-quote (car fp)) "\\>") + ;; newname)) + ;; (checkdoc-create-error + ;; "Flag variable names should normally end in `-flag'" s + ;; (marker-position e))))) ;; Done with variables )) (t @@ -1783,10 +1774,9 @@ function,command,variable,option or symbol." ms1)))))) checkdoc-common-verbs-wrong-voice)) (if (not rs) (error "Verb voice alist corrupted")) (setq replace (let ((case-fold-search nil)) - (save-match-data - (if (string-match "^[A-Z]" original) - (capitalize (cdr rs)) - (cdr rs))))) + (if (string-match-p "^[A-Z]" original) + (capitalize (cdr rs)) + (cdr rs)))) (if (checkdoc-autofix-ask-replace (match-beginning 1) (match-end 1) (format "Use the imperative for \"%s\". \ @@ -1814,11 +1804,10 @@ Replace with \"%s\"? " original replace) "[^-([`':a-zA-Z]\\(\\w+[:-]\\(\\w\\|\\s_\\)+\\)[^]']" e t)) (setq ms (match-string 1)) - (save-match-data - ;; A . is a \s_ char, so we must remove periods from - ;; sentences more carefully. - (if (string-match "\\.$" ms) - (setq ms (substring ms 0 (1- (length ms)))))) + ;; A . is a \s_ char, so we must remove periods from + ;; sentences more carefully. + (when (string-match-p "\\.$" ms) + (setq ms (substring ms 0 (1- (length ms))))) (if (and (not (checkdoc-in-sample-code-p start e)) (not (checkdoc-in-example-string-p start e)) (not (member ms checkdoc-symbol-words)) @@ -2616,7 +2605,9 @@ function called to create the messages." (checkdoc-output-mode) (setq default-directory dir) (goto-char (point-max)) - (insert "\n\n\C-l\n*** " label ": " check-type " V " checkdoc-version)))) + (let ((inhibit-read-only t)) + (insert "\n\n\C-l\n*** " label ": " + check-type " V " checkdoc-version))))) (defun checkdoc-error (point msg) "Store POINT and MSG as errors in the checkdoc diagnostic buffer." @@ -2627,7 +2618,8 @@ function called to create the messages." ": " msg))) (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) (goto-char (point-max)) - (apply 'insert text)))) + (let ((inhibit-read-only t)) + (apply 'insert text))))) (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." diff --git a/lisp/emacs-lisp/cl-compat.el b/lisp/emacs-lisp/cl-compat.el index 3d11214c892..3276f588e6a 100644 --- a/lisp/emacs-lisp/cl-compat.el +++ b/lisp/emacs-lisp/cl-compat.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -46,8 +44,15 @@ ;;; Code: -;; Require at load-time, but not when compiling cl-compat. -(or (featurep 'cl) (require 'cl)) +;; This used to be: +;; (or (featurep 'cl) (require 'cl)) +;; which just has the effect of fooling the byte-compiler into not +;; loading cl when compiling. However, that leads to some bogus +;; compiler warnings. Loading cl when compiling cannot do any harm, +;; because for a long time bootstrap-emacs contained 'cl, due to being +;; dumped from uncompiled files that eval-when-compile'd cl. So every +;; file was compiled with 'cl loaded. +(require 'cl) ;;; Keyword routines not supported by new package. @@ -186,5 +191,9 @@ (provide 'cl-compat) +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: + ;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163 ;;; cl-compat.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 5e19ac1c151..d999cb1d8da 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -43,6 +41,7 @@ ;;; Type coercion. +;;;###autoload (defun coerce (x type) "Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. @@ -60,6 +59,7 @@ TYPE is a Common Lisp type specifier. ;;; Predicates. +;;;###autoload (defun equalp (x y) "Return t if two Lisp objects have similar structures and contents. This is like `equal', except that it accepts numerically equal @@ -87,6 +87,7 @@ strings case-insensitively." ;;; Control structures. +;;;###autoload (defun cl-mapcar-many (cl-func cl-seqs) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) @@ -119,6 +120,7 @@ strings case-insensitively." cl-res))) (nreverse cl-res)))) +;;;###autoload (defun map (cl-type cl-func cl-seq &rest cl-rest) "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. @@ -126,6 +128,7 @@ TYPE is the sequence type to return. (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) (and cl-type (coerce cl-res cl-type)))) +;;;###autoload (defun maplist (cl-func cl-list &rest cl-rest) "Map FUNCTION to each sublist of LIST or LISTs. Like `mapcar', except applies to lists and their cdr's rather than to @@ -154,6 +157,7 @@ the elements themselves. cl-seq) (mapc cl-func cl-seq))) +;;;###autoload (defun mapl (cl-func cl-list &rest cl-rest) "Like `maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" @@ -163,16 +167,19 @@ the elements themselves. (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) cl-list) +;;;###autoload (defun mapcan (cl-func cl-seq &rest cl-rest) "Like `mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) +;;;###autoload (defun mapcon (cl-func cl-list &rest cl-rest) "Like `maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) +;;;###autoload (defun some (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of any element of SEQ or SEQs. If so, return the true (non-nil) value returned by PREDICATE. @@ -188,6 +195,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) cl-x))) +;;;###autoload (defun every (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" @@ -201,19 +209,23 @@ If so, return the true (non-nil) value returned by PREDICATE. (setq cl-seq (cdr cl-seq))) (null cl-seq))) +;;;###autoload (defun notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (not (apply 'some cl-pred cl-seq cl-rest))) +;;;###autoload (defun notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (not (apply 'every cl-pred cl-seq cl-rest))) ;;; Support for `loop'. +;;;###autoload (defalias 'cl-map-keymap 'map-keymap) +;;;###autoload (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) (or cl-base (setq cl-base (copy-sequence [0]))) @@ -228,6 +240,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (funcall cl-func-rec cl-base cl-bind)))) cl-map)) +;;;###autoload (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) (or cl-what (setq cl-what (current-buffer))) (if (bufferp cl-what) @@ -255,6 +268,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (funcall cl-func cl-start (min cl-next cl-end)) (setq cl-start cl-next))))) +;;;###autoload (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) (or cl-buffer (setq cl-buffer (current-buffer))) (if (fboundp 'overlay-lists) @@ -296,6 +310,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) ;;; Support for `setf'. +;;;###autoload (defun cl-set-frame-visible-p (frame val) (cond ((null val) (make-frame-invisible frame)) ((eq val 'icon) (iconify-frame frame)) @@ -304,6 +319,7 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;; Support for `progv'. (defvar cl-progv-save) +;;;###autoload (defun cl-progv-before (syms values) (while syms (push (if (boundp (car syms)) @@ -323,6 +339,7 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;; Numbers. +;;;###autoload (defun gcd (&rest args) "Return the greatest common divisor of the arguments." (let ((a (abs (or (pop args) 0)))) @@ -331,6 +348,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (while (> b 0) (setq b (% a (setq a b)))))) a)) +;;;###autoload (defun lcm (&rest args) "Return the least common multiple of the arguments." (if (memq 0 args) @@ -341,6 +359,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (setq a (* (/ a (gcd a b)) b)))) a))) +;;;###autoload (defun isqrt (x) "Return the integer square root of the argument." (if (and (integerp x) (> x 0)) @@ -352,12 +371,14 @@ If so, return the true (non-nil) value returned by PREDICATE. g) (if (eq x 0) 0 (signal 'arith-error nil)))) +;;;###autoload (defun floor* (x &optional y) "Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient." (let ((q (floor x y))) (list q (- x (if y (* y q) q))))) +;;;###autoload (defun ceiling* (x &optional y) "Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient." @@ -365,12 +386,14 @@ With two arguments, return ceiling and remainder of their quotient." (if (= (car (cdr res)) 0) res (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) +;;;###autoload (defun truncate* (x &optional y) "Return a list of the integer part of X and the fractional part of X. With two arguments, return truncation and remainder of their quotient." (if (eq (>= x 0) (or (null y) (>= y 0))) (floor* x y) (ceiling* x y))) +;;;###autoload (defun round* (x &optional y) "Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient." @@ -389,14 +412,17 @@ With two arguments, return rounding and remainder of their quotient." (let ((q (round x))) (list q (- x q)))))) +;;;###autoload (defun mod* (x y) "The remainder of X divided by Y, with the same sign as Y." (nth 1 (floor* x y))) +;;;###autoload (defun rem* (x y) "The remainder of X divided by Y, with the same sign as X." (nth 1 (truncate* x y))) +;;;###autoload (defun signum (x) "Return 1 if X is positive, -1 if negative, 0 if zero." (cond ((> x 0) 1) ((< x 0) -1) (t 0))) @@ -405,6 +431,7 @@ With two arguments, return rounding and remainder of their quotient." ;; Random numbers. (defvar *random-state*) +;;;###autoload (defun random* (lim &optional state) "Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object." @@ -412,7 +439,7 @@ Optional second arg STATE is a random-state object." ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) - (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii) + (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) (aset state 3 (setq vec (make-vector 55 nil))) (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) @@ -429,6 +456,7 @@ Optional second arg STATE is a random-state object." (if (< (setq n (logand n mask)) lim) n (random* lim state)))) (* (/ n '8388608e0) lim))))) +;;;###autoload (defun make-random-state (&optional state) "Return a copy of random-state STATE, or of `*random-state*' if omitted. If STATE is t, return a new state object seeded from the time of day." @@ -437,6 +465,7 @@ If STATE is t, return a new state object seeded from the time of day." ((integerp state) (vector 'cl-random-state-tag -1 30 state)) (t (make-random-state (cl-random-time))))) +;;;###autoload (defun random-state-p (object) "Return t if OBJECT is a random-state object." (and (vectorp object) (= (length object) 4) @@ -460,6 +489,7 @@ If STATE is t, return a new state object seeded from the time of day." (defvar float-epsilon) (defvar float-negative-epsilon) +;;;###autoload (defun cl-float-limits () (or most-positive-float (not (numberp '2e1)) (let ((x '2e0) y z) @@ -497,6 +527,7 @@ If STATE is t, return a new state object seeded from the time of day." ;;; Sequence functions. +;;;###autoload (defun subseq (seq start &optional end) "Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. @@ -522,6 +553,7 @@ If START or END is negative, it counts from the end." (setq i (1+ i) start (1+ start))) res)))))) +;;;###autoload (defun concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \n(fn TYPE SEQUENCE...)" @@ -533,14 +565,17 @@ If START or END is negative, it counts from the end." ;;; List functions. +;;;###autoload (defun revappend (x y) "Equivalent to (append (reverse X) Y)." (nconc (reverse x) y)) +;;;###autoload (defun nreconc (x y) "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) +;;;###autoload (defun list-length (x) "Return the length of list X. Return nil if list is circular." (let ((n 0) (fast x) (slow x)) @@ -548,6 +583,7 @@ If START or END is negative, it counts from the end." (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) (if fast (if (cdr fast) nil (1+ n)) n))) +;;;###autoload (defun tailp (sublist list) "Return true if SUBLIST is a tail of LIST." (while (and (consp list) (not (eq sublist list))) @@ -559,6 +595,7 @@ If START or END is negative, it counts from the end." ;;; Property lists. +;;;###autoload (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" @@ -569,6 +606,7 @@ If START or END is negative, it counts from the end." (setq plist (cdr (cdr plist)))) (if plist (car (cdr plist)) def))))) +;;;###autoload (defun getf (plist tag &optional def) "Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. @@ -583,16 +621,19 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (setq plist (cdr (cdr plist)))) (if plist (car (cdr plist)) def)))) +;;;###autoload (defun cl-set-getf (plist tag val) (let ((p plist)) (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) +;;;###autoload (defun cl-do-remf (plist tag) (let ((p (cdr plist))) (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) +;;;###autoload (defun cl-remprop (sym tag) "Remove from SYMBOL's plist the property PROPNAME and its value. \n(fn SYMBOL PROPNAME)" @@ -600,6 +641,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) (cl-do-remf plist tag)))) +;;;###autoload (defalias 'remprop 'cl-remprop) @@ -616,14 +658,22 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (defvar cl-builtin-clrhash (symbol-function 'clrhash)) (defvar cl-builtin-maphash (symbol-function 'maphash)) +;;;###autoload (defalias 'cl-gethash 'gethash) +;;;###autoload (defalias 'cl-puthash 'puthash) +;;;###autoload (defalias 'cl-remhash 'remhash) +;;;###autoload (defalias 'cl-clrhash 'clrhash) +;;;###autoload (defalias 'cl-maphash 'maphash) ;; These three actually didn't exist in Emacs-20. +;;;###autoload (defalias 'cl-make-hash-table 'make-hash-table) +;;;###autoload (defalias 'cl-hash-table-p 'hash-table-p) +;;;###autoload (defalias 'cl-hash-table-count 'hash-table-count) ;;; Some debugging aids. @@ -672,6 +722,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (defvar cl-macroexpand-cmacs nil) (defvar cl-closure-vars nil) +;;;###autoload (defun cl-macroexpand-all (form &optional env) "Expand all macro calls through a Lisp FORM. This also does some trivial optimizations to make the form prettier." @@ -753,6 +804,7 @@ This also does some trivial optimizations to make the form prettier." (defun cl-macroexpand-body (body &optional env) (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) +;;;###autoload (defun cl-prettyexpand (form &optional full) (message "Expanding...") (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) @@ -767,5 +819,9 @@ This also does some trivial optimizations to make the form prettier." (run-hooks 'cl-extra-load-hook) +;; Local variables: +;; generated-autoload-file: "cl-loaddefs.el" +;; End: + ;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed ;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 7525c2e5897..9ca2498858f 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -612,5 +610,5 @@ If nil, indent backquoted lists as data, i.e., like quoted lists." ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) -;;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03 +;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03 ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 1589e19cbb2..5fea98cff84 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,16 +10,16 @@ ;;;;;; 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" "47c92504dda976a632c2c10bedd4b6a4") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "0e52b41c758c56831930100671c58f50") ;;; Generated autoloads from cl-extra.el -(autoload (quote coerce) "cl-extra" "\ +(autoload 'coerce "cl-extra" "\ Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload (quote equalp) "cl-extra" "\ +(autoload 'equalp "cl-extra" "\ Return t if two Lisp objects have similar structures and contents. This is like `equal', except that it accepts numerically equal numbers of different types (float vs. integer), and also compares @@ -27,309 +27,303 @@ strings case-insensitively. \(fn X Y)" nil nil) -(autoload (quote cl-mapcar-many) "cl-extra" "\ +(autoload 'cl-mapcar-many "cl-extra" "\ Not documented \(fn CL-FUNC CL-SEQS)" nil nil) -(autoload (quote map) "cl-extra" "\ +(autoload 'map "cl-extra" "\ Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \(fn TYPE FUNCTION SEQUENCE...)" nil nil) -(autoload (quote maplist) "cl-extra" "\ +(autoload 'maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. Like `mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) -(autoload (quote mapl) "cl-extra" "\ +(autoload 'mapl "cl-extra" "\ Like `maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload (quote mapcan) "cl-extra" "\ +(autoload 'mapcan "cl-extra" "\ Like `mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) -(autoload (quote mapcon) "cl-extra" "\ +(autoload 'mapcon "cl-extra" "\ Like `maplist', but nconc's together the values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload (quote some) "cl-extra" "\ +(autoload 'some "cl-extra" "\ Return true if PREDICATE is true of any element of SEQ or SEQs. If so, return the true (non-nil) value returned by PREDICATE. \(fn PREDICATE SEQ...)" nil nil) -(autoload (quote every) "cl-extra" "\ +(autoload 'every "cl-extra" "\ Return true if PREDICATE is true of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload (quote notany) "cl-extra" "\ +(autoload 'notany "cl-extra" "\ Return true if PREDICATE is false of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload (quote notevery) "cl-extra" "\ +(autoload 'notevery "cl-extra" "\ Return true if PREDICATE is false of some element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(defalias (quote cl-map-keymap) (quote map-keymap)) +(defalias 'cl-map-keymap 'map-keymap) -(autoload (quote cl-map-keymap-recursively) "cl-extra" "\ +(autoload 'cl-map-keymap-recursively "cl-extra" "\ Not documented \(fn CL-FUNC-REC CL-MAP &optional CL-BASE)" nil nil) -(autoload (quote cl-map-intervals) "cl-extra" "\ +(autoload 'cl-map-intervals "cl-extra" "\ Not documented \(fn CL-FUNC &optional CL-WHAT CL-PROP CL-START CL-END)" nil nil) -(autoload (quote cl-map-overlays) "cl-extra" "\ +(autoload 'cl-map-overlays "cl-extra" "\ Not documented \(fn CL-FUNC &optional CL-BUFFER CL-START CL-END CL-ARG)" nil nil) -(autoload (quote cl-set-frame-visible-p) "cl-extra" "\ +(autoload 'cl-set-frame-visible-p "cl-extra" "\ Not documented \(fn FRAME VAL)" nil nil) -(autoload (quote cl-progv-before) "cl-extra" "\ +(autoload 'cl-progv-before "cl-extra" "\ Not documented \(fn SYMS VALUES)" nil nil) -(autoload (quote gcd) "cl-extra" "\ +(autoload 'gcd "cl-extra" "\ Return the greatest common divisor of the arguments. \(fn &rest ARGS)" nil nil) -(autoload (quote lcm) "cl-extra" "\ +(autoload 'lcm "cl-extra" "\ Return the least common multiple of the arguments. \(fn &rest ARGS)" nil nil) -(autoload (quote isqrt) "cl-extra" "\ +(autoload 'isqrt "cl-extra" "\ Return the integer square root of the argument. \(fn X)" nil nil) -(autoload (quote floor*) "cl-extra" "\ +(autoload 'floor* "cl-extra" "\ Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload (quote ceiling*) "cl-extra" "\ +(autoload 'ceiling* "cl-extra" "\ Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload (quote truncate*) "cl-extra" "\ +(autoload 'truncate* "cl-extra" "\ Return a list of the integer part of X and the fractional part of X. With two arguments, return truncation and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload (quote round*) "cl-extra" "\ +(autoload 'round* "cl-extra" "\ Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload (quote mod*) "cl-extra" "\ +(autoload 'mod* "cl-extra" "\ The remainder of X divided by Y, with the same sign as Y. \(fn X Y)" nil nil) -(autoload (quote rem*) "cl-extra" "\ +(autoload 'rem* "cl-extra" "\ The remainder of X divided by Y, with the same sign as X. \(fn X Y)" nil nil) -(autoload (quote signum) "cl-extra" "\ +(autoload 'signum "cl-extra" "\ Return 1 if X is positive, -1 if negative, 0 if zero. \(fn X)" nil nil) -(autoload (quote random*) "cl-extra" "\ +(autoload 'random* "cl-extra" "\ Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object. \(fn LIM &optional STATE)" nil nil) -(autoload (quote make-random-state) "cl-extra" "\ +(autoload 'make-random-state "cl-extra" "\ Return a copy of random-state STATE, or of `*random-state*' if omitted. If STATE is t, return a new state object seeded from the time of day. \(fn &optional STATE)" nil nil) -(autoload (quote random-state-p) "cl-extra" "\ +(autoload 'random-state-p "cl-extra" "\ Return t if OBJECT is a random-state object. \(fn OBJECT)" nil nil) -(autoload (quote cl-float-limits) "cl-extra" "\ +(autoload 'cl-float-limits "cl-extra" "\ Not documented \(fn)" nil nil) -(autoload (quote subseq) "cl-extra" "\ +(autoload 'subseq "cl-extra" "\ Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end. \(fn SEQ START &optional END)" nil nil) -(autoload (quote concatenate) "cl-extra" "\ +(autoload 'concatenate "cl-extra" "\ Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \(fn TYPE SEQUENCE...)" nil nil) -(autoload (quote revappend) "cl-extra" "\ +(autoload 'revappend "cl-extra" "\ Equivalent to (append (reverse X) Y). \(fn X Y)" nil nil) -(autoload (quote nreconc) "cl-extra" "\ +(autoload 'nreconc "cl-extra" "\ Equivalent to (nconc (nreverse X) Y). \(fn X Y)" nil nil) -(autoload (quote list-length) "cl-extra" "\ +(autoload 'list-length "cl-extra" "\ Return the length of list X. Return nil if list is circular. \(fn X)" nil nil) -(autoload (quote tailp) "cl-extra" "\ +(autoload 'tailp "cl-extra" "\ Return true if SUBLIST is a tail of LIST. \(fn SUBLIST LIST)" nil nil) -(autoload (quote get*) "cl-extra" "\ +(autoload 'get* "cl-extra" "\ Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) -(autoload (quote getf) "cl-extra" "\ +(autoload 'getf "cl-extra" "\ Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. \(fn PROPLIST PROPNAME &optional DEFAULT)" nil nil) -(autoload (quote cl-set-getf) "cl-extra" "\ +(autoload 'cl-set-getf "cl-extra" "\ Not documented \(fn PLIST TAG VAL)" nil nil) -(autoload (quote cl-do-remf) "cl-extra" "\ +(autoload 'cl-do-remf "cl-extra" "\ Not documented \(fn PLIST TAG)" nil nil) -(autoload (quote cl-remprop) "cl-extra" "\ +(autoload 'cl-remprop "cl-extra" "\ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) -(defalias (quote remprop) (quote cl-remprop)) +(defalias 'remprop 'cl-remprop) -(defalias (quote cl-gethash) (quote gethash)) +(defalias 'cl-gethash 'gethash) -(defalias (quote cl-puthash) (quote puthash)) +(defalias 'cl-puthash 'puthash) -(defalias (quote cl-remhash) (quote remhash)) +(defalias 'cl-remhash 'remhash) -(defalias (quote cl-clrhash) (quote clrhash)) +(defalias 'cl-clrhash 'clrhash) -(defalias (quote cl-maphash) (quote maphash)) +(defalias 'cl-maphash 'maphash) -(defalias (quote cl-make-hash-table) (quote make-hash-table)) +(defalias 'cl-make-hash-table 'make-hash-table) -(defalias (quote cl-hash-table-p) (quote hash-table-p)) +(defalias 'cl-hash-table-p 'hash-table-p) -(defalias (quote cl-hash-table-count) (quote hash-table-count)) +(defalias 'cl-hash-table-count 'hash-table-count) -(autoload (quote cl-macroexpand-all) "cl-extra" "\ +(autoload 'cl-macroexpand-all "cl-extra" "\ Expand all macro calls through a Lisp FORM. This also does some trivial optimizations to make the form prettier. \(fn FORM &optional ENV)" nil nil) -(autoload (quote cl-prettyexpand) "cl-extra" "\ +(autoload 'cl-prettyexpand "cl-extra" "\ Not documented \(fn FORM &optional FULL)" nil nil) ;;;*** -;;;### (autoloads (compiler-macroexpand define-compiler-macro ignore-errors -;;;;;; assert check-type typep 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-compile-time-init) "cl-macs" -;;;;;; "cl-macs.el" "7ccc827d272482ca276937ca18a7895a") +;;;### (autoloads (compiler-macroexpand define-compiler-macro assert +;;;;;; check-type typep 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" "db690711cf205074d21590cc64a26d89") ;;; Generated autoloads from cl-macs.el -(autoload (quote cl-compile-time-init) "cl-macs" "\ -Not documented - -\(fn)" nil nil) - -(autoload (quote gensym) "cl-macs" "\ +(autoload 'gensym "cl-macs" "\ Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload (quote gentemp) "cl-macs" "\ +(autoload 'gentemp "cl-macs" "\ Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload (quote defun*) "cl-macs" "\ +(autoload 'defun* "cl-macs" "\ Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) -(autoload (quote defmacro*) "cl-macs" "\ +(autoload 'defmacro* "cl-macs" "\ Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) -(autoload (quote function*) "cl-macs" "\ +(autoload 'function* "cl-macs" "\ Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions. \(fn FUNC)" nil (quote macro)) -(autoload (quote destructuring-bind) "cl-macs" "\ +(autoload 'destructuring-bind "cl-macs" "\ Not documented \(fn ARGS EXPR &rest BODY)" nil (quote macro)) -(autoload (quote eval-when) "cl-macs" "\ +(autoload 'eval-when "cl-macs" "\ Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. @@ -337,13 +331,13 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" nil (quote macro)) -(autoload (quote load-time-value) "cl-macs" "\ +(autoload 'load-time-value "cl-macs" "\ Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant. \(fn FORM &optional READ-ONLY)" nil (quote macro)) -(autoload (quote case) "cl-macs" "\ +(autoload 'case "cl-macs" "\ Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared against each key in each KEYLIST; the corresponding BODY is evaluated. @@ -354,13 +348,13 @@ Key values are compared by `eql'. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) -(autoload (quote ecase) "cl-macs" "\ +(autoload 'ecase "cl-macs" "\ Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) -(autoload (quote typecase) "cl-macs" "\ +(autoload 'typecase "cl-macs" "\ Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, @@ -369,13 +363,13 @@ final clause, and matches if no other keys match. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) -(autoload (quote etypecase) "cl-macs" "\ +(autoload 'etypecase "cl-macs" "\ Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) -(autoload (quote block) "cl-macs" "\ +(autoload 'block "cl-macs" "\ Define a lexically-scoped block named NAME. NAME may be any symbol. Code inside the BODY forms can call `return-from' to jump prematurely out of the block. This differs from `catch' and `throw' @@ -387,13 +381,13 @@ called from BODY. \(fn NAME &rest BODY)" nil (quote macro)) -(autoload (quote return) "cl-macs" "\ +(autoload 'return "cl-macs" "\ Return from the block named nil. This is equivalent to `(return-from nil RESULT)'. \(fn &optional RESULT)" nil (quote macro)) -(autoload (quote return-from) "cl-macs" "\ +(autoload 'return-from "cl-macs" "\ Return from the block named NAME. This jump out to the innermost enclosing `(block NAME ...)' form, returning RESULT from that form (or nil if RESULT is omitted). @@ -402,7 +396,7 @@ This is compatible with Common Lisp, but note that `defun' and \(fn NAME &optional RESULT)" nil (quote macro)) -(autoload (quote loop) "cl-macs" "\ +(autoload 'loop "cl-macs" "\ The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -418,24 +412,24 @@ Valid clauses are: \(fn CLAUSE...)" nil (quote macro)) -(autoload (quote do) "cl-macs" "\ +(autoload 'do "cl-macs" "\ The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) -(autoload (quote do*) "cl-macs" "\ +(autoload 'do* "cl-macs" "\ The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) -(autoload (quote dolist) "cl-macs" "\ +(autoload 'dolist "cl-macs" "\ Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. Then evaluate RESULT to get return value, default nil. \(fn (VAR LIST [RESULT]) BODY...)" nil (quote macro)) -(autoload (quote dotimes) "cl-macs" "\ +(autoload 'dotimes "cl-macs" "\ Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get return value, default @@ -443,26 +437,26 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" nil (quote macro)) -(autoload (quote do-symbols) "cl-macs" "\ +(autoload 'do-symbols "cl-macs" "\ Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) -(autoload (quote do-all-symbols) "cl-macs" "\ +(autoload 'do-all-symbols "cl-macs" "\ Not documented \(fn SPEC &rest BODY)" nil (quote macro)) -(autoload (quote psetq) "cl-macs" "\ +(autoload 'psetq "cl-macs" "\ Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) before assigning any symbols SYM to the corresponding values. \(fn SYM VAL SYM VAL ...)" nil (quote macro)) -(autoload (quote progv) "cl-macs" "\ +(autoload 'progv "cl-macs" "\ Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the @@ -472,7 +466,7 @@ a `let' form, except that the list of symbols can be computed at run-time. \(fn SYMBOLS VALUES &rest BODY)" nil (quote macro)) -(autoload (quote flet) "cl-macs" "\ +(autoload 'flet "cl-macs" "\ Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC rather than its value cell. The FORMs are evaluated with the specified @@ -481,41 +475,41 @@ go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) -(autoload (quote labels) "cl-macs" "\ +(autoload 'labels "cl-macs" "\ Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. Unlike `flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) -(autoload (quote macrolet) "cl-macs" "\ +(autoload 'macrolet "cl-macs" "\ Make temporary macro definitions. This is like `flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil (quote macro)) -(autoload (quote symbol-macrolet) "cl-macs" "\ +(autoload 'symbol-macrolet "cl-macs" "\ Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" nil (quote macro)) -(autoload (quote lexical-let) "cl-macs" "\ +(autoload 'lexical-let "cl-macs" "\ Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. \(fn VARLIST BODY)" nil (quote macro)) -(autoload (quote lexical-let*) "cl-macs" "\ +(autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. \(fn VARLIST BODY)" nil (quote macro)) -(autoload (quote multiple-value-bind) "cl-macs" "\ +(autoload 'multiple-value-bind "cl-macs" "\ Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements of this list bound (`let'-style) to each of the symbols SYM in turn. This @@ -525,7 +519,7 @@ a synonym for (list A B C). \(fn (SYM...) FORM BODY)" nil (quote macro)) -(autoload (quote multiple-value-setq) "cl-macs" "\ +(autoload 'multiple-value-setq "cl-macs" "\ Collect multiple return values. FORM must return a list; the first N elements of this list are stored in each of the symbols SYM in turn. This is analogous to the Common Lisp @@ -534,22 +528,22 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" nil (quote macro)) -(autoload (quote locally) "cl-macs" "\ +(autoload 'locally "cl-macs" "\ Not documented \(fn &rest BODY)" nil (quote macro)) -(autoload (quote the) "cl-macs" "\ +(autoload 'the "cl-macs" "\ Not documented \(fn TYPE FORM)" nil (quote macro)) -(autoload (quote declare) "cl-macs" "\ +(autoload 'declare "cl-macs" "\ Not documented \(fn &rest SPECS)" nil (quote macro)) -(autoload (quote define-setf-method) "cl-macs" "\ +(autoload 'define-setf-method "cl-macs" "\ Define a `setf' method. This method shows how to handle `setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were @@ -560,7 +554,7 @@ form. See `defsetf' for a simpler way to define most setf-methods. \(fn NAME ARGLIST BODY...)" nil (quote macro)) -(autoload (quote defsetf) "cl-macs" "\ +(autoload 'defsetf "cl-macs" "\ Define a `setf' method. This macro is an easy-to-use substitute for `define-setf-method' that works well for simple place forms. In the simple `defsetf' form, `setf's of @@ -581,14 +575,14 @@ Example: \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" nil (quote macro)) -(autoload (quote get-setf-method) "cl-macs" "\ +(autoload 'get-setf-method "cl-macs" "\ Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to a macro like `setf' or `incf'. \(fn PLACE &optional ENV)" nil nil) -(autoload (quote setf) "cl-macs" "\ +(autoload 'setf "cl-macs" "\ Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic references such as (car x) or (aref x i), as well as plain symbols. @@ -597,40 +591,40 @@ The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) -(autoload (quote psetf) "cl-macs" "\ +(autoload 'psetf "cl-macs" "\ Set PLACEs to the values VALs in parallel. This is like `setf', except that all VAL forms are evaluated (in order) before assigning any PLACEs to the corresponding values. \(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) -(autoload (quote cl-do-pop) "cl-macs" "\ +(autoload 'cl-do-pop "cl-macs" "\ Not documented \(fn PLACE)" nil nil) -(autoload (quote remf) "cl-macs" "\ +(autoload 'remf "cl-macs" "\ Remove TAG from property list PLACE. PLACE may be a symbol, or any generalized variable allowed by `setf'. The form returns true if TAG was found and removed, nil otherwise. \(fn PLACE TAG)" nil (quote macro)) -(autoload (quote shiftf) "cl-macs" "\ +(autoload 'shiftf "cl-macs" "\ Shift left among PLACEs. Example: (shiftf A B C) sets A to B, B to C, and returns the old A. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE... VAL)" nil (quote macro)) -(autoload (quote rotatef) "cl-macs" "\ +(autoload 'rotatef "cl-macs" "\ Rotate left among PLACEs. Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" nil (quote macro)) -(autoload (quote letf) "cl-macs" "\ +(autoload 'letf "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the sense of `setf') for the PLACEs. Each PLACE is set to the corresponding @@ -642,7 +636,7 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) -(autoload (quote letf*) "cl-macs" "\ +(autoload 'letf* "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the sense of `setf') for the PLACEs. Each PLACE is set to the corresponding @@ -654,27 +648,27 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) -(autoload (quote callf) "cl-macs" "\ +(autoload 'callf "cl-macs" "\ Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn FUNC PLACE ARGS...)" nil (quote macro)) -(autoload (quote callf2) "cl-macs" "\ +(autoload 'callf2 "cl-macs" "\ Set PLACE to (FUNC ARG1 PLACE ARGS...). Like `callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" nil (quote macro)) -(autoload (quote define-modify-macro) "cl-macs" "\ +(autoload 'define-modify-macro "cl-macs" "\ Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +) \(fn NAME ARGLIST FUNC &optional DOC)" nil (quote macro)) -(autoload (quote defstruct) "cl-macs" "\ +(autoload 'defstruct "cl-macs" "\ Define a struct type. This macro defines a new Lisp data type called NAME, which contains data stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME' @@ -682,24 +676,24 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. \(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)" nil (quote macro)) -(autoload (quote cl-struct-setf-expander) "cl-macs" "\ +(autoload 'cl-struct-setf-expander "cl-macs" "\ Not documented \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) -(autoload (quote typep) "cl-macs" "\ +(autoload 'typep "cl-macs" "\ Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload (quote check-type) "cl-macs" "\ +(autoload 'check-type "cl-macs" "\ Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type. \(fn FORM TYPE &optional STRING)" nil (quote macro)) -(autoload (quote assert) "cl-macs" "\ +(autoload 'assert "cl-macs" "\ Verify that FORM returns non-nil; signal an error if not. Second arg SHOW-ARGS means to include arguments of FORM in message. Other args STRING and ARGS... are arguments to be passed to `error'. @@ -708,13 +702,7 @@ omitted, a default message listing FORM itself is used. \(fn FORM &optional SHOW-ARGS STRING &rest ARGS)" nil (quote macro)) -(autoload (quote ignore-errors) "cl-macs" "\ -Execute BODY; if an error occurs, return nil. -Otherwise, return result of last form in BODY. - -\(fn &rest BODY)" nil (quote macro)) - -(autoload (quote define-compiler-macro) "cl-macs" "\ +(autoload 'define-compiler-macro "cl-macs" "\ Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to FUNC is compiled (i.e., not interpreted). Compiler macros should be used @@ -728,7 +716,7 @@ and then returning foo. \(fn FUNC ARGS &rest BODY)" nil (quote macro)) -(autoload (quote compiler-macroexpand) "cl-macs" "\ +(autoload 'compiler-macroexpand "cl-macs" "\ Not documented \(fn FORM)" nil nil) @@ -745,24 +733,24 @@ Not documented ;;;;;; 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" "8805f76626399794931f5db36ddf855f") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "50e97e33d680423c1a09239e41c42e3e") ;;; Generated autoloads from cl-seq.el -(autoload (quote reduce) "cl-seq" "\ +(autoload 'reduce "cl-seq" "\ Reduce two-argument FUNCTION across SEQ. Keywords supported: :start :end :from-end :initial-value :key \(fn FUNCTION SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote fill) "cl-seq" "\ +(autoload 'fill "cl-seq" "\ Fill the elements of SEQ with ITEM. Keywords supported: :start :end \(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil) -(autoload (quote replace) "cl-seq" "\ +(autoload 'replace "cl-seq" "\ Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -770,7 +758,7 @@ Keywords supported: :start1 :end1 :start2 :end2 \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove*) "cl-seq" "\ +(autoload 'remove* "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -779,7 +767,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-if) "cl-seq" "\ +(autoload 'remove-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -788,7 +776,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-if-not) "cl-seq" "\ +(autoload 'remove-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -797,7 +785,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete*) "cl-seq" "\ +(autoload 'delete* "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -805,7 +793,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-if) "cl-seq" "\ +(autoload 'delete-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -813,7 +801,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-if-not) "cl-seq" "\ +(autoload 'delete-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -821,21 +809,21 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-duplicates) "cl-seq" "\ +(autoload 'remove-duplicates "cl-seq" "\ Return a copy of SEQ with all duplicate elements removed. Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-duplicates) "cl-seq" "\ +(autoload 'delete-duplicates "cl-seq" "\ Remove all duplicate elements from SEQ (destructively). Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute) "cl-seq" "\ +(autoload 'substitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -844,7 +832,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute-if) "cl-seq" "\ +(autoload 'substitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -853,7 +841,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute-if-not) "cl-seq" "\ +(autoload 'substitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -862,7 +850,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute) "cl-seq" "\ +(autoload 'nsubstitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -870,7 +858,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute-if) "cl-seq" "\ +(autoload 'nsubstitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -878,7 +866,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute-if-not) "cl-seq" "\ +(autoload 'nsubstitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -886,7 +874,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find) "cl-seq" "\ +(autoload 'find "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. @@ -894,7 +882,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find-if) "cl-seq" "\ +(autoload 'find-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -902,7 +890,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find-if-not) "cl-seq" "\ +(autoload 'find-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -910,7 +898,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position) "cl-seq" "\ +(autoload 'position "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. @@ -918,7 +906,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position-if) "cl-seq" "\ +(autoload 'position-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -926,7 +914,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position-if-not) "cl-seq" "\ +(autoload 'position-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -934,28 +922,28 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count) "cl-seq" "\ +(autoload 'count "cl-seq" "\ Count the number of occurrences of ITEM in SEQ. Keywords supported: :test :test-not :key :start :end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count-if) "cl-seq" "\ +(autoload 'count-if "cl-seq" "\ Count the number of items satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count-if-not) "cl-seq" "\ +(autoload 'count-if-not "cl-seq" "\ Count the number of items not satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote mismatch) "cl-seq" "\ +(autoload 'mismatch "cl-seq" "\ Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorter sequence. @@ -964,7 +952,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote search) "cl-seq" "\ +(autoload 'search "cl-seq" "\ Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; return nil if there are no matches. @@ -973,7 +961,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote sort*) "cl-seq" "\ +(autoload 'sort* "cl-seq" "\ Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -981,7 +969,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote stable-sort) "cl-seq" "\ +(autoload 'stable-sort "cl-seq" "\ Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -989,7 +977,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote merge) "cl-seq" "\ +(autoload 'merge "cl-seq" "\ Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument sequences, and PREDICATE is a `less-than' predicate on the elements. @@ -998,7 +986,7 @@ Keywords supported: :key \(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote member*) "cl-seq" "\ +(autoload 'member* "cl-seq" "\ Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. @@ -1006,7 +994,7 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote member-if) "cl-seq" "\ +(autoload 'member-if "cl-seq" "\ Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1014,7 +1002,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote member-if-not) "cl-seq" "\ +(autoload 'member-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1022,54 +1010,54 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote cl-adjoin) "cl-seq" "\ +(autoload 'cl-adjoin "cl-seq" "\ Not documented \(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) -(autoload (quote assoc*) "cl-seq" "\ +(autoload 'assoc* "cl-seq" "\ Find the first item whose car matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote assoc-if) "cl-seq" "\ +(autoload 'assoc-if "cl-seq" "\ Find the first item whose car satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote assoc-if-not) "cl-seq" "\ +(autoload 'assoc-if-not "cl-seq" "\ Find the first item whose car does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc*) "cl-seq" "\ +(autoload 'rassoc* "cl-seq" "\ Find the first item whose cdr matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc-if) "cl-seq" "\ +(autoload 'rassoc-if "cl-seq" "\ Find the first item whose cdr satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc-if-not) "cl-seq" "\ +(autoload 'rassoc-if-not "cl-seq" "\ Find the first item whose cdr does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote union) "cl-seq" "\ +(autoload 'union "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1079,7 +1067,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nunion) "cl-seq" "\ +(autoload 'nunion "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1089,7 +1077,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote intersection) "cl-seq" "\ +(autoload 'intersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1099,7 +1087,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nintersection) "cl-seq" "\ +(autoload 'nintersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1109,7 +1097,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote set-difference) "cl-seq" "\ +(autoload 'set-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1119,7 +1107,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nset-difference) "cl-seq" "\ +(autoload 'nset-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1129,7 +1117,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote set-exclusive-or) "cl-seq" "\ +(autoload 'set-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1139,7 +1127,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nset-exclusive-or) "cl-seq" "\ +(autoload 'nset-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1149,7 +1137,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote subsetp) "cl-seq" "\ +(autoload 'subsetp "cl-seq" "\ Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. @@ -1157,7 +1145,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote subst-if) "cl-seq" "\ +(autoload 'subst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. @@ -1165,7 +1153,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote subst-if-not) "cl-seq" "\ +(autoload 'subst-if-not "cl-seq" "\ Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. @@ -1173,7 +1161,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst) "cl-seq" "\ +(autoload 'nsubst "cl-seq" "\ Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call to `setcar'). @@ -1182,7 +1170,7 @@ Keywords supported: :test :test-not :key \(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst-if) "cl-seq" "\ +(autoload 'nsubst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1190,7 +1178,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst-if-not) "cl-seq" "\ +(autoload 'nsubst-if-not "cl-seq" "\ Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1198,7 +1186,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote sublis) "cl-seq" "\ +(autoload 'sublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. @@ -1206,7 +1194,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsublis) "cl-seq" "\ +(autoload 'nsublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. @@ -1214,7 +1202,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote tree-equal) "cl-seq" "\ +(autoload 'tree-equal "cl-seq" "\ Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c75d3b9f9f0..9ca675f08c4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,4 +1,4 @@ -;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- +;;; cl-macs.el --- Common Lisp macros ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -45,9 +43,7 @@ ;;; Code: -(or (memq 'cl-19 features) - (error "Tried to load `cl-macs' before `cl'!")) - +(require 'cl) (defmacro cl-pop2 (place) (list 'prog1 (list 'car (list 'cdr place)) @@ -58,8 +54,8 @@ (defvar cl-optimize-speed) -;;; This kludge allows macros which use cl-transform-function-property -;;; to be called at compile-time. +;; This kludge allows macros which use cl-transform-function-property +;; to be called at compile-time. (require (progn @@ -75,10 +71,6 @@ (defvar cl-old-bc-file-form nil) -(defun cl-compile-time-init () - (run-hooks 'cl-hack-bytecomp-hook)) - - ;;; Some predicates for analyzing Lisp forms. These are used by various ;;; macro expanders to optimize the results in certain common cases. @@ -165,6 +157,7 @@ ;;; Symbols. (defvar *gensym-counter*) +;;;###autoload (defun gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." @@ -174,6 +167,7 @@ The name is made by appending a number to PREFIX, default \"G\"." (setq *gensym-counter* (1+ *gensym-counter*)))))) (make-symbol (format "%s%d" pfix num)))) +;;;###autoload (defun gentemp (&optional prefix) "Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\"." @@ -186,6 +180,7 @@ The name is made by appending a number to PREFIX, default \"G\"." ;;; Program structure. +;;;###autoload (defmacro defun* (name args &rest body) "Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, @@ -196,6 +191,7 @@ and BODY is implicitly surrounded by (block NAME ...). (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;;;###autoload (defmacro defmacro* (name args &rest body) "Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, @@ -206,6 +202,7 @@ and BODY is implicitly surrounded by (block NAME ...). (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;;;###autoload (defmacro function* (func) "Introduce a function. Like normal `function', except that if argument is a lambda form, @@ -426,6 +423,7 @@ its argument list allows full Common Lisp conventions." (setq res (nconc res (cl-arglist-args arg)))))) (nconc res (and args (list args)))))) +;;;###autoload (defmacro destructuring-bind (args expr &rest body) (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) (bind-defs nil) (bind-block 'cl-none)) @@ -439,6 +437,7 @@ its argument list allows full Common Lisp conventions." (defvar cl-not-toplevel nil) +;;;###autoload (defmacro eval-when (when &rest body) "Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. @@ -470,6 +469,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. form))) (t (eval form) form))) +;;;###autoload (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." @@ -492,6 +492,7 @@ The result of the body appears to the compiler as a quoted constant." ;;; Conditional control structures. +;;;###autoload (defmacro case (expr &rest clauses) "Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared @@ -526,12 +527,14 @@ Key values are compared by `eql'. (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) +;;;###autoload (defmacro ecase (expr &rest clauses) "Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (list* 'case expr (append clauses '((ecase-error-flag))))) +;;;###autoload (defmacro typecase (expr &rest clauses) "Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it @@ -558,6 +561,7 @@ final clause, and matches if no other keys match. (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) +;;;###autoload (defmacro etypecase (expr &rest clauses) "Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. @@ -567,6 +571,7 @@ final clause, and matches if no other keys match. ;;; Blocks and exits. +;;;###autoload (defmacro block (name &rest body) "Define a lexically-scoped block named NAME. NAME may be any symbol. Code inside the BODY forms can call `return-from' @@ -602,11 +607,13 @@ called from BODY." (if cl-found (setcdr cl-found t))) (byte-compile-normal-call (cons 'throw (cdr cl-form)))) +;;;###autoload (defmacro return (&optional result) "Return from the block named nil. This is equivalent to `(return-from nil RESULT)'." (list 'return-from nil result)) +;;;###autoload (defmacro return-from (name &optional result) "Return from the block named NAME. This jump out to the innermost enclosing `(block NAME ...)' form, @@ -626,6 +633,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar loop-result) (defvar loop-result-explicit) (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) +;;;###autoload (defmacro loop (&rest args) "The Common Lisp `loop' macro. Valid clauses are: @@ -1185,12 +1193,14 @@ Valid clauses are: ;;; Other iteration control structures. +;;;###autoload (defmacro do (steps endtest &rest body) "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (cl-expand-do-loop steps endtest body nil)) +;;;###autoload (defmacro do* (steps endtest &rest body) "The Common Lisp `do*' loop. @@ -1218,6 +1228,7 @@ Valid clauses are: (apply 'append sets))))))) (or (cdr endtest) '(nil))))) +;;;###autoload (defmacro dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. @@ -1234,6 +1245,7 @@ Then evaluate RESULT to get return value, default nil. (cons (list 'setq (car spec) nil) (cdr (cdr spec))) '(nil)))))) +;;;###autoload (defmacro dotimes (spec &rest body) "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, @@ -1248,6 +1260,7 @@ nil. (append body (list (list 'incf (car spec))))) (or (cdr (cdr spec)) '(nil)))))) +;;;###autoload (defmacro do-symbols (spec &rest body) "Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol @@ -1262,12 +1275,14 @@ from OBARRAY. (and (cadr spec) (list (cadr spec)))) (caddr spec)))) +;;;###autoload (defmacro do-all-symbols (spec &rest body) (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) ;;; Assignments. +;;;###autoload (defmacro psetq (&rest args) "Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) @@ -1279,6 +1294,7 @@ before assigning any symbols SYM to the corresponding values. ;;; Binding control structures. +;;;###autoload (defmacro progv (symbols values &rest body) "Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. @@ -1292,6 +1308,7 @@ a `let' form, except that the list of symbols can be computed at run-time." '(cl-progv-after)))) ;;; This should really have some way to shadow 'byte-compile properties, etc. +;;;###autoload (defmacro flet (bindings &rest body) "Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC @@ -1319,6 +1336,7 @@ go back to their previous definitions, or lack thereof). bindings) body)) +;;;###autoload (defmacro labels (bindings &rest body) "Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. @@ -1343,6 +1361,7 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. ;; The following ought to have a better definition for use with newer ;; byte compilers. +;;;###autoload (defmacro macrolet (bindings &rest body) "Make temporary macro definitions. This is like `flet', but for macros instead of functions. @@ -1359,6 +1378,7 @@ This is like `flet', but for macros instead of functions. (cons (list* name 'lambda (cdr res)) cl-macro-environment)))))) +;;;###autoload (defmacro symbol-macrolet (bindings &rest body) "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced @@ -1375,6 +1395,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). cl-macro-environment))))) (defvar cl-closure-vars nil) +;;;###autoload (defmacro lexical-let (bindings &rest body) "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -1418,6 +1439,7 @@ lexical closures as in Common Lisp. vars)) ebody)))) +;;;###autoload (defmacro lexical-let* (bindings &rest body) "Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -1438,6 +1460,7 @@ lexical closures as in Common Lisp. ;;; Multiple values. +;;;###autoload (defmacro multiple-value-bind (vars form &rest body) "Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements @@ -1455,6 +1478,7 @@ a synonym for (list A B C). vars)) body))) +;;;###autoload (defmacro multiple-value-setq (vars form) "Collect multiple return values. FORM must return a list; the first N elements of this list are stored in @@ -1481,7 +1505,9 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Declarations. +;;;###autoload (defmacro locally (&rest body) (cons 'progn body)) +;;;###autoload (defmacro the (type form) form) (defvar cl-proclaim-history t) ; for future compilers @@ -1519,15 +1545,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). byte-compile-delete-errors (nth 1 safety))))) ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) - (if (eq byte-compile-warnings t) - (setq byte-compile-warnings byte-compile-warning-types)) (while (setq spec (cdr spec)) (if (consp (car spec)) (if (eq (cadar spec) 0) - (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) - (setq byte-compile-warnings - (adjoin (caar spec) byte-compile-warnings))))))) + (byte-compile-disable-warning (caar spec)) + (byte-compile-enable-warning (caar spec))))))) nil) ;;; Process any proclamations made before cl-macs was loaded. @@ -1536,6 +1558,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (while p (cl-do-proclaim (pop p) t)) (setq cl-proclaims-deferred nil)) +;;;###autoload (defmacro declare (&rest specs) (if (cl-compiling-file) (while specs @@ -1547,6 +1570,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Generalized variables. +;;;###autoload (defmacro define-setf-method (func args &rest body) "Define a `setf' method. This method shows how to handle `setf's to places of the form (NAME ARGS...). @@ -1565,8 +1589,9 @@ form. See `defsetf' for a simpler way to define most setf-methods. func 'setf-method (cons args body))))) (defalias 'define-setf-expander 'define-setf-method) +;;;###autoload (defmacro defsetf (func arg1 &rest args) - "(defsetf NAME FUNC): define a `setf' method. + "Define a `setf' method. This macro is an easy-to-use substitute for `define-setf-method' that works well for simple place forms. In the simple `defsetf' form, `setf's of the form (setf (NAME ARGS...) VAL) are transformed to function or macro @@ -1585,7 +1610,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" - (if (listp arg1) + (if (and (listp arg1) (consp args)) (let* ((largs nil) (largsr nil) (temps nil) (tempsr nil) (restarg nil) (rest-temps nil) @@ -1723,7 +1748,7 @@ Example: (defsetf frame-parameters modify-frame-parameters t) (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-width set-screen-width t) -(defsetf frame-parameter set-frame-parameter) +(defsetf frame-parameter set-frame-parameter t) (defsetf getenv setenv t) (defsetf get-register set-register) (defsetf global-key-binding global-set-key) @@ -1840,6 +1865,7 @@ Example: (list 'substring (nth 4 method) from-temp to-temp)))) ;;; Getting and optimizing setf-methods. +;;;###autoload (defun get-setf-method (place &optional env) "Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to @@ -1859,8 +1885,7 @@ a macro like `setf' or `incf'." method (error "Setf-method for %s returns malformed method" func))) - (and (save-match-data - (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) + (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name) (get-setf-method (compiler-macroexpand place))) (and (eq func 'edebug-after) (get-setf-method (nth (1- (length place)) place) @@ -1907,6 +1932,7 @@ a macro like `setf' or `incf'." (not (eq (car-safe (symbol-function (car form))) 'macro)))) ;;; The standard modify macros. +;;;###autoload (defmacro setf (&rest args) "Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic @@ -1925,6 +1951,7 @@ The return value is the last VAL in the list. (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) (if (car method) (list 'let* (car method) store) store))))) +;;;###autoload (defmacro psetf (&rest args) "Set PLACEs to the values VALs in parallel. This is like `setf', except that all VAL forms are evaluated (in order) @@ -1948,6 +1975,7 @@ before assigning any PLACEs to the corresponding values. (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) (list 'progn expr nil))))) +;;;###autoload (defun cl-do-pop (place) (if (cl-simple-expr-p place) (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) @@ -1960,6 +1988,7 @@ before assigning any PLACEs to the corresponding values. (list 'car temp) (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) +;;;###autoload (defmacro remf (place tag) "Remove TAG from property list PLACE. PLACE may be a symbol, or any generalized variable allowed by `setf'. @@ -1980,6 +2009,7 @@ The form returns true if TAG was found and removed, nil otherwise." t) (list 'cl-do-remf tval ttag))))) +;;;###autoload (defmacro shiftf (place &rest args) "Shift left among PLACEs. Example: (shiftf A B C) sets A to B, B to C, and returns the old A. @@ -1995,6 +2025,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (prog1 ,(nth 2 method) ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) +;;;###autoload (defmacro rotatef (&rest args) "Rotate left among PLACEs. Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. @@ -2020,6 +2051,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (list 'let* (append (car method) (list (list temp (nth 2 method)))) (cl-setf-do-store (nth 1 method) form) nil))))) +;;;###autoload (defmacro letf (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the @@ -2076,6 +2108,7 @@ the PLACE is not modified before executing BODY. rev (cdr rev)))) (list* 'let* lets body)))) +;;;###autoload (defmacro letf* (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the @@ -2094,6 +2127,7 @@ the PLACE is not modified before executing BODY. (setq body (list (list* 'letf (list (pop bindings)) body)))) (car body))) +;;;###autoload (defmacro callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, @@ -2108,6 +2142,7 @@ or any generalized variable allowed by `setf'. (list* 'funcall (list 'function func) rargs)))))) +;;;###autoload (defmacro callf2 (func arg1 place &rest args) "Set PLACE to (FUNC ARG1 PLACE ARGS...). Like `callf', but PLACE is the second argument of FUNC, not the first. @@ -2124,6 +2159,7 @@ Like `callf', but PLACE is the second argument of FUNC, not the first. (list* 'funcall (list 'function func) rargs))))))) +;;;###autoload (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments @@ -2138,6 +2174,7 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" ;;; Structures. +;;;###autoload (defmacro defstruct (struct &rest descs) "Define a struct type. This macro defines a new Lisp data type called NAME, which contains data @@ -2362,6 +2399,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. forms) (cons 'progn (nreverse (cons (list 'quote name) forms))))) +;;;###autoload (defun cl-struct-setf-expander (x name accessor pred-form pos) (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) (list (list temp) (list x) (list store) @@ -2404,7 +2442,7 @@ The type name can then be used in `typecase', `check-type', etc." ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef - ((memq type '(character string-char)) `(char-valid-p ,val)) + ((memq type '(character string-char)) `(characterp ,val)) (t (let* ((name (symbol-name type)) (namep (intern (concat name "p")))) @@ -2430,11 +2468,13 @@ The type name can then be used in `typecase', `check-type', etc." ((eq (car type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type))))) +;;;###autoload (defun typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." (eval (cl-make-type-test 'object type))) +;;;###autoload (defmacro check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." @@ -2449,6 +2489,7 @@ STRING is an optional description of the desired type." (if (eq temp form) (list 'progn body nil) (list 'let (list (list temp form)) body nil))))) +;;;###autoload (defmacro assert (form &optional show-args string &rest args) "Verify that FORM returns non-nil; signal an error if not. Second arg SHOW-ARGS means to include arguments of FORM in message. @@ -2457,11 +2498,12 @@ They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) + (let ((sargs (and show-args + (delq nil (mapcar + (lambda (x) + (unless (cl-const-expr-p x) + x)) + (cdr form)))))) (list 'progn (list 'or form (if string @@ -2470,14 +2512,9 @@ omitted, a default message listing FORM itself is used." (list* 'list (list 'quote form) sargs)))) nil)))) -(defmacro ignore-errors (&rest body) - "Execute BODY; if an error occurs, return nil. -Otherwise, return result of last form in BODY." - `(condition-case nil (progn ,@body) (error nil))) - - ;;; Compiler macros. +;;;###autoload (defmacro define-compiler-macro (func args &rest body) "Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to @@ -2501,6 +2538,7 @@ and then returning foo." (list 'put (list 'quote func) '(quote byte-compile) '(quote cl-byte-compile-compiler-macro))))) +;;;###autoload (defun compiler-macroexpand (form) (while (let ((func (car-safe form)) (handler nil)) @@ -2556,9 +2594,9 @@ surrounded by (block NAME ...). (if lets (list 'let lets body) body)))) -;;; Compile-time optimizations for some functions defined in this package. -;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, -;;; mainly to make sure these macros will be present. +;; Compile-time optimizations for some functions defined in this package. +;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, +;; mainly to make sure these macros will be present. (put 'eql 'byte-compile nil) (define-compiler-macro eql (&whole form a b) @@ -2669,9 +2707,11 @@ surrounded by (block NAME ...). (run-hooks 'cl-macs-load-hook) -;;; Local variables: -;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) -;;; End: +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; 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 78799b6ffe3..2f5ff258bca 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,7 +1,7 @@ -;;; cl-seq.el --- Common Lisp features, part 3 -*-byte-compile-dynamic: t;-*- +;;; cl-seq.el --- Common Lisp features, part 3 -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -33,8 +31,6 @@ ;; This package was written by Dave Gillespie; it is a complete ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. ;; -;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. -;; ;; Bug reports, comments, and suggestions are welcome! ;; This file contains the Common Lisp sequence and list functions @@ -45,9 +41,7 @@ ;;; Code: -(or (memq 'cl-19 features) - (error "Tried to load `cl-seq' before `cl'!")) - +(require 'cl) ;;; Keyword parsing. This is special-cased here so that we can compile ;;; this file independent from cl-macs. @@ -125,6 +119,7 @@ (defvar cl-key) +;;;###autoload (defun reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key @@ -145,6 +140,7 @@ (cl-check-key (pop cl-seq)))))) cl-accum))) +;;;###autoload (defun fill (seq item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end @@ -164,6 +160,7 @@ (setq cl-start (1+ cl-start))))) seq)) +;;;###autoload (defun replace (cl-seq1 cl-seq2 &rest cl-keys) "Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -206,6 +203,7 @@ SEQ1 is destructively modified, then returned. (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) cl-seq1)) +;;;###autoload (defun remove* (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -251,6 +249,7 @@ to avoid corrupting the original SEQ. cl-seq)) cl-seq))))) +;;;###autoload (defun remove-if (cl-pred cl-list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -259,6 +258,7 @@ to avoid corrupting the original SEQ. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'remove* nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun remove-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -267,6 +267,7 @@ to avoid corrupting the original SEQ. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun delete* (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -310,6 +311,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. cl-seq) (apply 'remove* cl-item cl-seq cl-keys))))) +;;;###autoload (defun delete-if (cl-pred cl-list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -317,6 +319,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'delete* nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun delete-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -324,12 +327,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun remove-duplicates (cl-seq &rest cl-keys) "Return a copy of SEQ with all duplicate elements removed. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" (cl-delete-duplicates cl-seq cl-keys t)) +;;;###autoload (defun delete-duplicates (cl-seq &rest cl-keys) "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end @@ -376,6 +381,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) +;;;###autoload (defun substitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -397,6 +403,7 @@ to avoid corrupting the original SEQ. (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) +;;;###autoload (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -405,6 +412,7 @@ to avoid corrupting the original SEQ. \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary @@ -413,6 +421,7 @@ to avoid corrupting the original SEQ. \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -446,6 +455,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-start (1+ cl-start)))))) cl-seq)) +;;;###autoload (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -453,6 +463,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -460,6 +471,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun find (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. @@ -468,6 +480,7 @@ Return the matching ITEM, or nil if not found. (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) (and cl-pos (elt cl-seq cl-pos)))) +;;;###autoload (defun find-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -475,6 +488,7 @@ Return the matching item, or nil if not found. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'find nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun find-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -482,6 +496,7 @@ Return the matching item, or nil if not found. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'find nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun position (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. @@ -512,6 +527,7 @@ Return the index of the matching item, or nil if not found. (setq cl-start (1+ cl-start))) (and (< cl-start cl-end) cl-start)))) +;;;###autoload (defun position-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -519,6 +535,7 @@ Return the index of the matching item, or nil if not found. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'position nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun position-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -526,6 +543,7 @@ Return the index of the matching item, or nil if not found. \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'position nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun count (cl-item cl-seq &rest cl-keys) "Count the number of occurrences of ITEM in SEQ. \nKeywords supported: :test :test-not :key :start :end @@ -540,18 +558,21 @@ Return the index of the matching item, or nil if not found. (setq cl-start (1+ cl-start))) cl-count))) +;;;###autoload (defun count-if (cl-pred cl-list &rest cl-keys) "Count the number of items satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'count nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun count-if-not (cl-pred cl-list &rest cl-keys) "Count the number of items not satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" (apply 'count nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) "Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the @@ -582,6 +603,7 @@ other, the return value indicates the end of the shorter sequence. (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) cl-start1))))) +;;;###autoload (defun search (cl-seq1 cl-seq2 &rest cl-keys) "Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; @@ -608,6 +630,7 @@ return nil if there are no matches. (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) (and (< cl-start2 cl-end2) cl-pos))))) +;;;###autoload (defun sort* (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -622,6 +645,7 @@ This is a destructive function; it reuses the storage of SEQ if possible. (funcall cl-pred (funcall cl-key cl-x) (funcall cl-key cl-y))))))))) +;;;###autoload (defun stable-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -629,6 +653,7 @@ This is a destructive function; it reuses the storage of SEQ if possible. \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" (apply 'sort* cl-seq cl-pred cl-keys)) +;;;###autoload (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) "Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument @@ -647,6 +672,7 @@ sequences, and PREDICATE is a `less-than' predicate on the elements. (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) ;;; See compiler macro in cl-macs.el +;;;###autoload (defun member* (cl-item cl-list &rest cl-keys) "Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. @@ -661,6 +687,7 @@ Return the sublist of LIST whose car is ITEM. (member cl-item cl-list) (memq cl-item cl-list)))) +;;;###autoload (defun member-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -668,6 +695,7 @@ Return the sublist of LIST whose car matches. \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'member* nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun member-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -675,6 +703,7 @@ Return the sublist of LIST whose car matches. \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'member* nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun cl-adjoin (cl-item cl-list &rest cl-keys) (if (cl-parsing-keywords (:key) t (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) @@ -682,6 +711,7 @@ Return the sublist of LIST whose car matches. (cons cl-item cl-list))) ;;; See compiler macro in cl-macs.el +;;;###autoload (defun assoc* (cl-item cl-alist &rest cl-keys) "Find the first item whose car matches ITEM in LIST. \nKeywords supported: :test :test-not :key @@ -697,18 +727,21 @@ Return the sublist of LIST whose car matches. (assoc cl-item cl-alist) (assq cl-item cl-alist)))) +;;;###autoload (defun assoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose car satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'assoc* nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun assoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose car does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun rassoc* (cl-item cl-alist &rest cl-keys) "Find the first item whose cdr matches ITEM in LIST. \nKeywords supported: :test :test-not :key @@ -722,18 +755,21 @@ Return the sublist of LIST whose car matches. (and cl-alist (car cl-alist))) (rassq cl-item cl-alist))) +;;;###autoload (defun rassoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) +;;;###autoload (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) +;;;###autoload (defun union (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. @@ -754,6 +790,7 @@ to avoid corrupting the original LIST1 and LIST2. (pop cl-list2)) cl-list1))) +;;;###autoload (defun nunion (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. @@ -764,6 +801,7 @@ whenever possible. (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) (t (apply 'union cl-list1 cl-list2 cl-keys)))) +;;;###autoload (defun intersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. @@ -786,6 +824,7 @@ to avoid corrupting the original LIST1 and LIST2. (pop cl-list2)) cl-res))))) +;;;###autoload (defun nintersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. @@ -795,6 +834,7 @@ whenever possible. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) +;;;###autoload (defun set-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. @@ -814,6 +854,7 @@ to avoid corrupting the original LIST1 and LIST2. (pop cl-list1)) cl-res)))) +;;;###autoload (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. @@ -824,6 +865,7 @@ whenever possible. (if (or (null cl-list1) (null cl-list2)) cl-list1 (apply 'set-difference cl-list1 cl-list2 cl-keys))) +;;;###autoload (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. @@ -836,6 +878,7 @@ to avoid corrupting the original LIST1 and LIST2. (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) (apply 'set-difference cl-list2 cl-list1 cl-keys))))) +;;;###autoload (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. @@ -848,6 +891,7 @@ whenever possible. (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) +;;;###autoload (defun subsetp (cl-list1 cl-list2 &rest cl-keys) "Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. @@ -862,6 +906,7 @@ I.e., if every element of LIST1 also appears in LIST2. (pop cl-list1)) (null cl-list1))))) +;;;###autoload (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. @@ -869,6 +914,7 @@ Return a copy of TREE with all matching elements replaced by NEW. \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) +;;;###autoload (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. @@ -876,6 +922,7 @@ Return a copy of TREE with all non-matching elements replaced by NEW. \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) +;;;###autoload (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call @@ -884,6 +931,7 @@ to `setcar'). \n(fn NEW OLD TREE [KEYWORD VALUE]...)" (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) +;;;###autoload (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -891,6 +939,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar'). \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) +;;;###autoload (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -898,6 +947,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar'). \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) +;;;###autoload (defun sublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. @@ -920,6 +970,7 @@ Return a copy of TREE with all matching elements replaced. (cons cl-a cl-d))) cl-tree)))) +;;;###autoload (defun nsublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. @@ -944,6 +995,7 @@ Any matching element of TREE is changed via a call to `setcar'. (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) (setq cl-tree (cdr cl-tree)))))) +;;;###autoload (defun tree-equal (cl-x cl-y &rest cl-keys) "Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. @@ -961,5 +1013,11 @@ Atoms are compared by `eql'; cons cells are compared recursively. (run-hooks 'cl-seq-load-hook) -;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; generated-autoload-file: "cl-loaddefs.el" +;; End: + +;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el index dc8ebef69d5..c11774949c6 100644 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@ -11,10 +11,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -22,9 +22,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -92,7 +90,7 @@ ((&rest (symbol sexp)) cl-declarations body)) (def-edebug-spec destructuring-bind - (&define cl-macro-list form cl-declarations def-body)) + (&define cl-macro-list def-form cl-declarations def-body)) ;; Setf @@ -470,5 +468,5 @@ (def-edebug-spec loop-d-type-spec (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) -;;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478 +;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478 ;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 887e3d727a3..d757d60b3da 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,4 +1,4 @@ -;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*- +;;; cl.el --- Common Lisp extensions for Emacs ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -109,12 +107,15 @@ printer proceeds to the next function on the list. This variable is not used at present, but it is defined in hopes that a future Emacs interpreter will be able to use it.") -(add-hook 'cl-unload-hook 'cl-cannot-unload) -(defun cl-cannot-unload () - (error "Cannot unload the feature `cl'")) +(defun cl-unload-function () + "Stop unloading of the Common Lisp extensions." + (message "Cannot unload the feature `cl'") + ;; stop standard unloading! + t) -;;; Generalized variables. These macros are defined here so that they -;;; can safely be used in .emacs files. +;;; Generalized variables. +;; These macros are defined here so that they +;; can safely be used in .emacs files. (defmacro incf (place &optional x) "Increment PLACE by X (1 by default). @@ -132,6 +133,9 @@ The return value is the decremented value of PLACE." (list 'setq place (if x (list '- place x) (list '1- place))) (list 'callf '- place (or x 1)))) +;; Autoloaded, but we haven't loaded cl-loaddefs yet. +(declare-function cl-do-pop "cl-macs" (place)) + (defmacro pop (place) "Remove and return the head of the list stored in PLACE. Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more @@ -165,7 +169,7 @@ an element already on the list. (defun cl-set-elt (seq n val) (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) -(defun cl-set-nthcdr (n list x) +(defsubst cl-set-nthcdr (n list x) (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) (defun cl-set-buffer-substring (start end val) @@ -185,8 +189,8 @@ an element already on the list. ;;; Control structures. -;;; These macros are so simple and so often-used that it's better to have -;;; them all the time than to load them from cl-macs.el. +;; These macros are so simple and so often-used that it's better to have +;; them all the time than to load them from cl-macs.el. (defun cl-map-extents (&rest cl-args) (apply 'cl-map-overlays cl-args)) @@ -198,9 +202,10 @@ an element already on the list. (defalias 'cl-block-throw 'throw) -;;; Multiple values. True multiple values are not supported, or even -;;; simulated. Instead, multiple-value-bind and friends simply expect -;;; the target form to return the values as a list. +;;; Multiple values. +;; True multiple values are not supported, or even +;; simulated. Instead, multiple-value-bind and friends simply expect +;; the target form to return the values as a list. (defsubst values (&rest values) "Return multiple values, Common Lisp style. @@ -321,7 +326,7 @@ always returns nil." (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) -;;; The following are actually set by cl-float-limits. +;; The following are actually set by cl-float-limits. (defconst most-positive-float nil) (defconst most-negative-float nil) (defconst least-positive-float nil) @@ -336,6 +341,8 @@ always returns nil." (defalias 'copy-seq 'copy-sequence) +(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) + (defun mapcar* (cl-func cl-x &rest cl-rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. If there are several SEQs, FUNCTION is called with that many arguments, @@ -585,126 +592,81 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. -(defvar cl-fake-autoloads nil - "Non-nil means don't make CL functions autoload.") - -;;; Autoload the other portions of the package. +;; Define data for indentation and edebug. +(dolist (entry + '(((defun* defmacro*) 2) + ((function*) nil + (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) + ((eval-when) 1 (sexp &rest form)) + ((declare) nil (&rest sexp)) + ((the) 1 (sexp &rest form)) + ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) + ((block return-from) 1 (sexp &rest form)) + ((return) nil (&optional form)) + ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) + (form &rest form) + &rest form)) + ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) + ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) + ((psetq setf psetf) nil edebug-setq-form) + ((progv) 2 (&rest form)) + ((flet labels macrolet) 1 + ((&rest (sexp sexp &rest form)) &rest form)) + ((symbol-macrolet lexical-let lexical-let*) 1 + ((&rest &or symbolp (symbolp form)) &rest form)) + ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) + ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) + ((incf decf remf pushnew shiftf rotatef) nil (&rest form)) + ((letf letf*) 1 ((&rest (&rest form)) &rest form)) + ((callf destructuring-bind) 2 (sexp form &rest form)) + ((callf2) 3 (sexp form form &rest form)) + ((loop) nil (&rest &or symbolp form)) + ((ignore-errors) 0 (&rest form)))) + (dolist (func (car entry)) + (put func 'lisp-indent-function (nth 1 entry)) + (put func 'lisp-indent-hook (nth 1 entry)) + (or (get func 'edebug-form-spec) + (put func 'edebug-form-spec (nth 2 entry))))) + +;; Autoload the other portions of the package. ;; We want to replace the basic versions of dolist, dotimes, declare below. (fmakunbound 'dolist) (fmakunbound 'dotimes) (fmakunbound 'declare) -(mapcar (function - (lambda (set) - (let ((file (if cl-fake-autoloads "<none>" (car set)))) - (mapcar (function - (lambda (func) - (autoload func (car set) nil nil (nth 1 set)))) - (cddr set))))) - '(("cl-extra" nil - coerce equalp cl-map-keymap maplist mapc mapl mapcan mapcon - cl-map-keymap cl-map-keymap-recursively cl-map-intervals - cl-map-overlays cl-set-frame-visible-p cl-float-limits - gcd lcm isqrt floor* ceiling* truncate* round* - mod* rem* signum random* make-random-state random-state-p - subseq concatenate cl-mapcar-many map some every notany - notevery revappend nreconc list-length tailp copy-tree get* getf - cl-set-getf cl-do-remf remprop cl-make-hash-table cl-hash-lookup - cl-gethash cl-puthash cl-remhash cl-clrhash cl-maphash cl-hash-table-p - cl-hash-table-count cl-progv-before cl-prettyexpand - cl-macroexpand-all) - ("cl-seq" nil - reduce fill replace remove* remove-if remove-if-not - delete* delete-if delete-if-not remove-duplicates - delete-duplicates substitute substitute-if substitute-if-not - nsubstitute nsubstitute-if nsubstitute-if-not find find-if - find-if-not position position-if position-if-not count count-if - count-if-not mismatch search sort* stable-sort merge member* - member-if member-if-not cl-adjoin assoc* assoc-if assoc-if-not - rassoc* rassoc-if rassoc-if-not union nunion intersection - nintersection set-difference nset-difference set-exclusive-or - nset-exclusive-or subsetp subst-if subst-if-not nsubst nsubst-if - nsubst-if-not sublis nsublis tree-equal) - ("cl-macs" nil - gensym gentemp typep cl-do-pop get-setf-method - cl-struct-setf-expander compiler-macroexpand cl-compile-time-init) - ("cl-macs" t - defun* defmacro* function* destructuring-bind eval-when - load-time-value case ecase typecase etypecase - block return return-from loop do do* dolist dotimes do-symbols - do-all-symbols psetq progv flet labels macrolet symbol-macrolet - lexical-let lexical-let* multiple-value-bind multiple-value-setq - locally the declare define-setf-method defsetf define-modify-macro - setf psetf remf shiftf rotatef letf letf* callf callf2 defstruct - check-type assert ignore-errors define-compiler-macro))) - -;;; Define data for indentation and edebug. -(mapcar (function - (lambda (entry) - (mapcar (function - (lambda (func) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - (car entry)))) - '(((defun* defmacro*) 2) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) nil (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) - - -;;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") +(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. -;;; As a side effect, we cause cl-macs to be loaded when compiling, so -;;; that the compiler-macros defined there will be present. +;; Things to do after byte-compiler is loaded. (defvar cl-hacked-flag nil) (defun cl-hack-byte-compiler () - (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) - (progn - (setq cl-hacked-flag t) ; Do it first, to prevent recursion. - (cl-compile-time-init)))) ; In cl-macs.el. + (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form) + (progn + (setq cl-hacked-flag t) ; Do it first, to prevent recursion. + (load "cl-macs" nil t) + (run-hooks 'cl-hack-bytecomp-hook)))) -;;; Try it now in case the compiler has already been loaded. +;; Try it now in case the compiler has already been loaded. (cl-hack-byte-compiler) -;;; Also make a hook in case compiler is loaded after this file. +;; Also make a hook in case compiler is loaded after this file. (add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler) -;;; The following ensures that packages which expect the old-style cl.el -;;; will be happy with this one. +;; The following ensures that packages which expect the old-style cl.el +;; will be happy with this one. (provide 'cl) (run-hooks 'cl-load-hook) +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; End: + ;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 96c846d912a..f8894a7975d 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -43,17 +41,30 @@ A value of nil means to search whole buffer." :type '(choice (integer :tag "Limit") (const :tag "No limit"))) -;; The character classes have the Latin-1 version and the Latin-9 -;; version, which is probably enough. +(defcustom copyright-at-end-flag nil + "Non-nil means to search backwards from the end of the buffer for copyright. +This is useful for ChangeLogs." + :group 'copyright + :type 'boolean + :version "23.1") + (defcustom copyright-regexp - "\\([©Ž©]\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ -\\|[Cc]opyright\\s *:?\\s *[©Ž©]\\)\ + "\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ +\\|[Cc]opyright\\s *:?\\s *©\\)\ \\s *\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "What your copyright notice looks like. The second \\( \\) construct must match the years." :group 'copyright :type 'regexp) +(defcustom copyright-names-regexp "" + "Regexp matching the names which correspond to the user. +Only copyright lines where the name matches this regexp will be updated. +This allows you to avoid adding years to a copyright notice belonging to +someone else or to a group for which you do not work." + :group 'copyright + :type 'regexp) + (defcustom copyright-years-regexp "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "Match additional copyright notice years. @@ -82,10 +93,47 @@ When this is `function', only ask when called non-interactively." (defvar copyright-current-year (substring (current-time-string) -4) "String representing the current year.") +(defsubst copyright-limit () ; re-search-forward BOUND + (and copyright-limit + (if copyright-at-end-flag + (- (point) copyright-limit) + (+ (point) copyright-limit)))) + +(defun copyright-re-search (regexp &optional bound noerror count) + "Re-search forward or backward depending on `copyright-at-end-flag'." + (if copyright-at-end-flag + (re-search-backward regexp bound noerror count) + (re-search-forward regexp bound noerror count))) + +(defun copyright-start-point () + "Return point-min or point-max, depending on `copyright-at-end-flag'." + (if copyright-at-end-flag + (point-max) + (point-min))) + +(defun copyright-offset-too-large-p () + "Return non-nil if point is too far from the edge of the buffer." + (when copyright-limit + (if copyright-at-end-flag + (< (point) (- (point-max) copyright-limit)) + (> (point) (+ (point-min) copyright-limit))))) + (defun copyright-update-year (replace noquery) - (when (re-search-forward copyright-regexp - (if copyright-limit (+ (point) copyright-limit)) t) - ;; If the years are continued onto multiple lined + (when + (condition-case err + ;; (1) Need the extra \\( \\) around copyright-regexp because we + ;; goto (match-end 1) below. See note (2) below. + (copyright-re-search (concat "\\(" copyright-regexp + "\\)\\([ \t]*\n\\)?.*\\(?:" + copyright-names-regexp "\\)") + (copyright-limit) + t) + ;; In case the regexp is rejected. This is useful because + ;; copyright-update is typically called from before-save-hook where + ;; such an error is very inconvenient for the user. + (error (message "Can't update copyright: %s" err) nil)) + (goto-char (match-end 1)) + ;; If the years are continued onto multiple lines ;; that are marked as comments, skip to the end of the years anyway. (while (save-excursion (and (eq (following-char) ?,) @@ -96,15 +144,16 @@ When this is `function', only ask when called non-interactively." (forward-line 1) (and (looking-at comment-start-skip) (goto-char (match-end 0)))) - (save-match-data - (looking-at copyright-years-regexp)))) + (looking-at-p copyright-years-regexp))) (forward-line 1) (re-search-forward comment-start-skip) - (re-search-forward copyright-years-regexp)) + ;; (2) Need the extra \\( \\) so that the years are subexp 3, as + ;; they are at note (1) above. + (re-search-forward (format "\\(%s\\)" copyright-years-regexp))) ;; Note that `current-time-string' isn't locale-sensitive. (setq copyright-current-year (substring (current-time-string) -4)) - (unless (string= (buffer-substring (- (match-end 2) 2) (match-end 2)) + (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) (substring copyright-current-year -2)) (if (or noquery (y-or-n-p (if replace @@ -113,7 +162,7 @@ When this is `function', only ask when called non-interactively." (concat "Add " copyright-current-year " to copyright? ")))) (if replace - (replace-match copyright-current-year t t nil 2) + (replace-match copyright-current-year t t nil 3) (let ((size (save-excursion (skip-chars-backward "0-9")))) (if (and (eq (% (- (string-to-number copyright-current-year) (string-to-number (buffer-substring @@ -154,21 +203,24 @@ interactively." (save-excursion (save-restriction (widen) - (goto-char (point-min)) + (goto-char (copyright-start-point)) (copyright-update-year arg noquery) - (goto-char (point-min)) + (goto-char (copyright-start-point)) (and copyright-current-gpl-version ;; match the GPL version comment in .el files, including the ;; bilingual Esperanto one in two-column, and in texinfo.tex - (re-search-forward + (copyright-re-search "\\(the Free Software Foundation;\ either \\|; a\\^u eldono \\([0-9]+\\)a, ? a\\^u (la\\^u via \\)\ version \\([0-9]+\\), or (at" - (if copyright-limit (+ (point) copyright-limit)) t) - (not (string= (match-string 3) copyright-current-gpl-version)) + (copyright-limit) t) + ;; Don't update if the file is already using a more recent + ;; version than the "current" one. + (< (string-to-number (match-string 3)) + (string-to-number copyright-current-gpl-version)) (or noquery - (y-or-n-p (concat "Replace GPL version by " - copyright-current-gpl-version "? "))) + (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 @@ -185,9 +237,8 @@ version \\([0-9]+\\), or (at" Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." (interactive) (widen) - (goto-char (point-min)) - (if (re-search-forward copyright-regexp - (if copyright-limit (+ (point) copyright-limit)) t) + (goto-char (copyright-start-point)) + (if (copyright-re-search copyright-regexp (copyright-limit) t) (let ((s (match-beginning 2)) (e (copy-marker (1+ (match-end 2)))) (p (make-marker)) @@ -211,7 +262,7 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." ;; Don't mess up whitespace after the years. (skip-chars-backward " \t") (save-restriction - (narrow-to-region (point-min) (point)) + (narrow-to-region (copyright-start-point) (point)) (let ((fill-prefix " ")) (fill-region s last)))) (set-marker e nil) @@ -227,15 +278,25 @@ Uses heuristic: year >= 50 means 19xx, < 50 means 20xx." "Copyright (C) " `(substring (current-time-string) -4) " by " (or (getenv "ORGANIZATION") str) - '(if (and copyright-limit (> (point) (+ (point-min) copyright-limit))) + '(if (copyright-offset-too-large-p) (message "Copyright extends beyond `copyright-limit' and won't be updated automatically.")) comment-end \n) +(defun copyright-update-directory (directory match) + "Update copyright notice for all files in DIRECTORY matching MATCH." + (interactive "DDirectory: \nMFilenames matching: ") + (dolist (file (directory-files directory t match nil)) + (find-file file) + (let ((copyright-query nil)) + (copyright-update)) + (save-buffer) + (kill-buffer (current-buffer)))) + (provide 'copyright) ;; For the copyright sign: ;; Local Variables: -;; coding: emacs-mule +;; coding: utf-8 ;; End: ;; arch-tag: b4991afb-b6b1-4590-bebe-e076d9d4aee8 diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 10a67eac281..8a15bb25025 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -60,7 +58,12 @@ ;; `completing-read'. They should be similar -- it was intentional. ;; Some of this code started out as translation from C code in -;; src/minibuf.c to Emacs Lisp code. +;; src/minibuf.c to Emacs Lisp code. After this code was rewritten in Elisp +;; and made to operate on any field, this file was completely rewritten to +;; just reuse that code. + +;; Thanks to Sen Nagata <sen@eccosys.com> for the original version of the +;; code, and sorry for throwing it all out. --Stef ;; Thanks to Richard Stallman for all of his help (many of the good ;; ideas in here are from him), Gerd Moellmann for his attention, @@ -69,21 +72,24 @@ ;;; Questions and Thoughts: -;; -the author has gone through a number of test-and-fix cycles w/ -;; this code, so it should be usable. please let me know if you find -;; any problems. - ;; -should `completing-read-multiple' allow a trailing separator in ;; a return value when REQUIRE-MATCH is t? if not, should beep when a user ;; tries to exit the minibuffer via RET? -;; -TODO: possibly make return values from `crm-do-completion' into constants - -;; -TODO: find out whether there is an appropriate way to distinguish between -;; functions intended for internal use and those that aren't. - ;; -tip: use M-f and M-b for ease of navigation among elements. +;; - the difference between minibuffer-completion-table and +;; crm-completion-table is just crm--collection-fn. In most cases it +;; shouldn't make any difference. But if a non-CRM completion function +;; happens to be used, it will use minibuffer-completion-table and +;; crm--collection-fn will try to make it do "more or less the right +;; thing" by making it complete on the last element, which is about as +;; good as we can hope for right now. +;; I'm not sure if it's important or not. Maybe we could just throw away +;; crm-completion-table and crm--collection-fn, but there doesn't seem to +;; be a pressing need for it, and since Sen did bother to write it, we may +;; as well keep it, in case it helps. + ;;; History: ;; ;; 2000-04-10: @@ -100,12 +106,26 @@ It should be a single character string that doesn't appear in the list of completion candidates. Modify this value to make `completing-read-multiple' use a separator other than `crm-default-separator'.") -;; actual filling in of these maps occurs below via `crm-init-keymaps' -(defvar crm-local-completion-map nil +(defvar crm-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map [remap minibuffer-complete] #'crm-complete) + (define-key map [remap minibuffer-complete-word] #'crm-complete-word) + (define-key map [remap minibuffer-completion-help] #'crm-completion-help) + map) "Local keymap for minibuffer multiple input with completion. Analog of `minibuffer-local-completion-map'.") -(defvar crm-local-must-match-map nil +(defvar crm-local-must-match-map + (let ((map (make-sparse-keymap))) + ;; We'd want to have multiple inheritance here. + (set-keymap-parent map minibuffer-local-must-match-map) + (define-key map [remap minibuffer-complete] #'crm-complete) + (define-key map [remap minibuffer-complete-word] #'crm-complete-word) + (define-key map [remap minibuffer-completion-help] #'crm-completion-help) + (define-key map [remap minibuffer-complete-and-exit] + #'crm-complete-and-exit) + map) "Local keymap for minibuffer multiple input with exact match completion. Analog of `minibuffer-local-must-match-map' for crm.") @@ -114,38 +134,8 @@ Analog of `minibuffer-local-must-match-map' for crm.") This is a table used for completion by `completing-read-multiple' and its supporting functions.") -;; this is supposed to be analogous to last_exact_completion in src/minibuf.c -(defvar crm-last-exact-completion nil - "Completion string if last attempt reported \"Complete, but not unique\".") - -(defvar crm-left-of-element nil - "String to the left of the current element.") - -(defvar crm-current-element nil - "The current element.") - -(defvar crm-right-of-element nil - "String to the right of the current element.") - -(defvar crm-beginning-of-element nil - "Buffer position representing the beginning of the current element.") - -(defvar crm-end-of-element nil - "Buffer position representing the end of the current element.") - -;; emulates temp_echo_area_glyphs from src/minibuf.c -(defun crm-temp-echo-area-glyphs (message-string) - "Temporarily display MESSAGE-STRING in echo area. -After user-input or 2 seconds, erase the displayed string." - (save-excursion - (goto-char (point-max)) - (insert message-string) - (sit-for 2) - (backward-char (length message-string)) - (delete-char (length message-string)))) - ;; this function evolved from a posting by Stefan Monnier -(defun crm-collection-fn (string predicate flag) +(defun crm--collection-fn (string predicate flag) "Function used by `completing-read-multiple' to compute completion values. The value of STRING is the string to be completed. @@ -159,407 +149,84 @@ A value of nil specifies `try-completion'. A value of t specifies For more information on STRING, PREDICATE, and FLAG, see the Elisp Reference sections on 'Programmed Completion' and 'Basic Completion Functions'." - (let ((lead "")) - (when (string-match (concat ".*" crm-separator) string) - (setq lead (substring string 0 (match-end 0))) - (setq string (substring string (match-end 0)))) - (if (eq flag 'lambda) - ;; return t for exact match, nil otherwise - (let ((result (try-completion string crm-completion-table predicate))) - (if (stringp result) - nil - (if result - t - nil)))) - (if flag - ;; called via (all-completions string 'crm-completion-fn predicate)? - (all-completions string crm-completion-table predicate) - ;; called via (try-completion string 'crm-completion-fn predicate)? - (let ((result (try-completion string crm-completion-table predicate))) - (if (stringp result) - (concat lead result) - result))))) - -(defun crm-find-current-element () + (let ((beg 0)) + (while (string-match crm-separator string beg) + (setq beg (match-end 0))) + (completion-table-with-context (substring string 0 beg) + crm-completion-table + (substring string beg) + predicate + flag))) + +(defun crm--select-current-element () "Parse the minibuffer to find the current element. -If no element can be found, return nil. - -If an element is found, bind: - - -the variable `crm-current-element' to the current element, - - -the variables `crm-left-of-element' and `crm-right-of-element' to - the strings to the left and right of the current element, - respectively, and - - -the variables `crm-beginning-of-element' and `crm-end-of-element' to - the buffer positions of the beginning and end of the current element - respectively, - -and return t." - (let* ((prompt-end (minibuffer-prompt-end)) - (minibuffer-string (buffer-substring prompt-end (point-max))) - (end-index (or (string-match "," minibuffer-string (- (point) prompt-end)) - (- (point-max) prompt-end))) - (target-string (substring minibuffer-string 0 end-index)) - (index (or (string-match - (concat crm-separator "\\([^" crm-separator "]*\\)$") - target-string) - (string-match - (concat "^\\([^" crm-separator "]*\\)$") - target-string)))) - (if (not (numberp index)) - ;; no candidate found - nil - (progn - ;; - (setq crm-beginning-of-element (match-beginning 1)) - (setq crm-end-of-element (+ end-index prompt-end)) - ;; string to the left of the current element - (setq crm-left-of-element - (substring target-string 0 (match-beginning 1))) - ;; the current element - (setq crm-current-element (match-string 1 target-string)) - ;; string to the right of the current element - (setq crm-right-of-element (substring minibuffer-string end-index)) - t)))) - -(defun crm-test-completion (candidate) - "Return t if CANDIDATE is an exact match for a valid completion." - (let ((completions - ;; TODO: verify whether the arguments are appropriate - (all-completions - candidate crm-completion-table minibuffer-completion-predicate))) - (if (member candidate completions) - t - nil))) - -(defun crm-minibuffer-completion-help () +Place an overlay on the element, with a `field' property, and return it." + (let* ((bob (minibuffer-prompt-end)) + (start (save-excursion + (if (re-search-backward crm-separator bob t) + (match-end 0) + bob))) + (end (save-excursion + (if (re-search-forward crm-separator nil t) + (match-beginning 0) + (point-max)))) + (ol (make-overlay start end nil nil t))) + (overlay-put ol 'field (make-symbol "crm")) + ol)) + +(defun crm-completion-help () "Display a list of possible completions of the current minibuffer element." (interactive) - (message "Making completion list...") - (if (not (crm-find-current-element)) - nil - (let ((completions (all-completions crm-current-element - minibuffer-completion-table - minibuffer-completion-predicate))) - (message nil) - (if (null completions) - (crm-temp-echo-area-glyphs " [No completions]") - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (sort completions 'string-lessp) - crm-current-element))))) + (let ((ol (crm--select-current-element))) + (unwind-protect + (minibuffer-completion-help) + (delete-overlay ol))) nil) -(defun crm-do-completion () - "This is the internal completion engine. -This function updates the text in the minibuffer -to complete the current string, and returns a number between 0 and 6. -The meanings of the return values are: - - 0 - the string has no possible completion - 1 - the string is already a valid and unique match - 2 - not used - 3 - the string is already a valid match (but longer matches exist too) - 4 - the string was completed to a valid match - 5 - some completion has been done, but the result is not a match - 6 - no completion was done, and the string is not an exact match" - - (if (not (crm-find-current-element)) - nil - (let (last completion completedp) - (setq completion - (try-completion crm-current-element - minibuffer-completion-table - minibuffer-completion-predicate)) - (setq last crm-last-exact-completion) - (setq crm-last-exact-completion nil) - - (catch 'crm-exit - - (if (null completion) ; no possible completion - (progn - (crm-temp-echo-area-glyphs " [No match]") - (throw 'crm-exit 0))) - - (if (eq completion t) ; was already an exact and unique completion - (throw 'crm-exit 1)) - - (setq completedp - (null (string-equal completion crm-current-element))) - - (if completedp - (progn - (delete-region (minibuffer-prompt-end) (point-max)) - (insert crm-left-of-element completion) - ;; (if crm-complete-up-to-point - ;; (insert crm-separator)) - (insert crm-right-of-element) - (backward-char (length crm-right-of-element)) - ;; TODO: is this correct? - (setq crm-current-element completion))) - - (if (null (crm-test-completion crm-current-element)) - (progn - (if completedp ; some completion happened - (throw 'crm-exit 5) - (if completion-auto-help - (crm-minibuffer-completion-help) - (crm-temp-echo-area-glyphs " [Next char not unique]"))) - (throw 'crm-exit 6)) - (if completedp - (throw 'crm-exit 4))) - - (setq crm-last-exact-completion completion) - (if (not (null last)) - (progn - (if (not (null (equal crm-current-element last))) - (crm-minibuffer-completion-help)))) - - ;; returning -- was already an exact completion - (throw 'crm-exit 3))))) - -(defun crm-minibuffer-complete () +(defun crm-complete () "Complete the current element. If no characters can be completed, display a list of possible completions. Return t if the current element is now a valid match; otherwise return nil." (interactive) - ;; take care of scrolling if necessary -- completely cribbed from minibuf.c - (if (not (eq last-command this-command)) - ;; ok? - (setq minibuffer-scroll-window nil)) - (let ((window minibuffer-scroll-window)) - (if (and (not (null window)) - ;; ok? - (not (null (window-buffer window)))) - (let (tem) - (set-buffer (window-buffer window)) - ;; ok? - (setq tem (pos-visible-in-window-p (point-max) window)) - (if (not (null tem)) - ;; ok? - (set-window-start window (point-min) nil) - (scroll-other-window nil)) - ;; reaching here means exiting the function w/ return value of nil - nil) - - (let* ( - ;(crm-end-of-element nil) - (result (crm-do-completion))) - (cond - ((eq 0 result) - nil) - ((eq 1 result) - ;; adapted from Emacs 21 - (if (not (eq (point) crm-end-of-element)) - (goto-char (+ 1 crm-end-of-element))) - (crm-temp-echo-area-glyphs " [Sole completion]") - t) - ((eq 3 result) - ;; adapted from Emacs 21 - (if (not (eq (point) crm-end-of-element)) - (goto-char (+ 1 crm-end-of-element))) - (crm-temp-echo-area-glyphs " [Complete, but not unique]") - t)))))) - -;; i love traffic lights...but only when they're green -(defun crm-find-longest-completable-substring (string) - "Determine the longest completable (left-anchored) substring of STRING. -The description \"left-anchored\" means the positions of the characters -in the substring must be the same as those of the corresponding characters -in STRING. Anchoring is what `^' does in a regular expression. - -The table and predicate used for completion are -`minibuffer-completion-table' and `minibuffer-completion-predicate', -respectively. - -A non-nil return value means that there is some substring which is -completable. A return value of t means that STRING itself is -completable. If a string value is returned it is the longest -completable proper substring of STRING. If nil is returned, STRING -does not have any non-empty completable substrings. - -Remember: \"left-anchored\" substring" - (let* ((length-of-string (length string)) - (index length-of-string) - (done (if (> length-of-string 0) - nil - t)) - (first t) ; ugh, special handling for first time through... - goal-string - result) - ;; loop through left-anchored substrings in order of descending length, - ;; find the first substring that is completable - (while (not done) - (setq result (try-completion (substring string 0 index) - minibuffer-completion-table - minibuffer-completion-predicate)) - (if result - ;; found completable substring - (progn - (setq done t) - (if (and (eq result t) first) - ;; exactly matching string first time through - (setq goal-string t) - ;; fully-completed proper substring - (setq goal-string (substring string 0 index))))) - (setq index (1- index)) - (if first - (setq first nil)) - (if (<= index 0) - (setq done t))) - ;; possible values include: t, nil, some string - goal-string)) - -;; TODO: decide whether trailing separator is allowed. current -;; implementation appears to allow it -(defun crm-strings-completed-p (separated-string) - "Verify that strings in SEPARATED-STRING are completed strings. -A return value of t means that all strings were verified. A number is -returned if verification was unsuccessful. This number represents the -position in SEPARATED-STRING up to where completion was successful." - (let ((strings (split-string separated-string crm-separator)) - ;; buffers start at 1, not 0 - (current-position 1) - current-string - result - done) - (while (and strings (not done)) - (setq current-string (car strings) - result (try-completion current-string - minibuffer-completion-table - minibuffer-completion-predicate)) - (if (eq result t) - (setq strings (cdr strings) - current-position (+ current-position - (length current-string) - ;; automatically adding 1 for separator - ;; character - 1)) - ;; still one more case of a match - (if (stringp result) - (let ((string-list - (all-completions result - minibuffer-completion-table - minibuffer-completion-predicate))) - (if (member result string-list) - ;; ho ho, code duplication... - (setq strings (cdr strings) - current-position (+ current-position - (length current-string) - 1)) - (progn - (setq done t) - ;; current-string is a partially-completed string - (setq current-position (+ current-position - (length current-string)))))) - ;; current-string cannot be completed - (let ((completable-substring - (crm-find-longest-completable-substring current-string))) - (setq done t) - (setq current-position (+ current-position - (length completable-substring))))))) - ;; return our result - (if (null strings) - t - current-position))) - -;; try to complete candidate, then check all separated strings. move -;; point to problem position if checking fails for some string. if -;; checking succeeds for all strings, exit. -(defun crm-minibuffer-complete-and-exit () + (let ((ol (crm--select-current-element))) + (unwind-protect + (minibuffer-complete) + (delete-overlay ol)))) + +(defun crm-complete-word () + "Complete the current element at most a single word. +Like `minibuffer-complete-word' but for `completing-read-multiple'." + (interactive) + (let ((ol (crm--select-current-element))) + (unwind-protect + (minibuffer-complete-word) + (delete-overlay ol)))) + +(defun crm-complete-and-exit () "If all of the minibuffer elements are valid completions then exit. All elements in the minibuffer must match. If there is a mismatch, move point to the location of mismatch and do not exit. -This function is modeled after `minibuffer_complete_and_exit' in src/minibuf.c" +This function is modeled after `minibuffer-complete-and-exit'." (interactive) - - (if (not (crm-find-current-element)) - nil - (let (result) - - (setq result - (catch 'crm-exit - - (if (eq (minibuffer-prompt-end) (point-max)) - (throw 'crm-exit t)) - - ;; TODO: this test is suspect? - (if (not (null (crm-test-completion crm-current-element))) - (throw 'crm-exit "check")) - - ;; TODO: determine how to detect errors - (let ((result (crm-do-completion))) - - (cond - ((or (eq 1 result) - (eq 3 result)) - (throw 'crm-exit "check")) - ((eq 4 result) - (if (not (null minibuffer-completion-confirm)) - (progn - (crm-temp-echo-area-glyphs " [Confirm]") - nil) - (throw 'crm-exit "check"))) - (nil))))) - - (if (null result) - nil - (if (equal result "check") - (let ((check-strings - (crm-strings-completed-p - (buffer-substring (minibuffer-prompt-end) (point-max))))) - ;; check all of minibuffer - (if (eq check-strings t) - (throw 'exit nil) - (if (numberp check-strings) - (progn - (goto-char check-strings) - (crm-temp-echo-area-glyphs " [An element did not match]")) - (message "Unexpected error")))) - (if (eq result t) - (throw 'exit nil) - (message "Unexpected error"))))))) - -(defun crm-init-keymaps () - "Initialize the keymaps used by `completing-read-multiple'. -Two keymaps are used depending on the value of the REQUIRE-MATCH -argument of the function `completing-read-multiple'. - -If REQUIRE-MATCH is nil, the keymap `crm-local-completion-map' is used. -This keymap inherits from the keymap named `minibuffer-local-completion-map'. -The only difference is that TAB is bound to `crm-minibuffer-complete' in -the inheriting keymap. - -If REQUIRE-MATCH is non-nil, the keymap `crm-local-must-match-map' is used. -This keymap inherits from the keymap named `minibuffer-local-must-match-map'. -The inheriting keymap binds RET to `crm-minibuffer-complete-and-exit' -and TAB to `crm-minibuffer-complete'." - (unless crm-local-completion-map - (setq crm-local-completion-map (make-sparse-keymap)) - (set-keymap-parent crm-local-completion-map - minibuffer-local-completion-map) - ;; key definitions - (define-key crm-local-completion-map - (kbd "TAB") - (function crm-minibuffer-complete))) - - (unless crm-local-must-match-map - (setq crm-local-must-match-map (make-sparse-keymap)) - (set-keymap-parent crm-local-must-match-map - minibuffer-local-must-match-map) - ;; key definitions - (define-key crm-local-must-match-map - (kbd "RET") - (function crm-minibuffer-complete-and-exit)) - (define-key crm-local-must-match-map - (kbd "TAB") - (function crm-minibuffer-complete)))) - -(crm-init-keymaps) + (let ((doexit t)) + (goto-char (minibuffer-prompt-end)) + (while + (and doexit + (let ((ol (crm--select-current-element))) + (goto-char (overlay-end ol)) + (unwind-protect + (catch 'exit + (minibuffer-complete-and-exit) + ;; This did not throw `exit', so there was a problem. + (setq doexit nil)) + (goto-char (overlay-end ol)) + (delete-overlay ol)) + (not (eobp)))) + ;; Skip to the next element. + (forward-char 1)) + (if doexit (exit-minibuffer)))) ;; superemulates behavior of completing_read in src/minibuf.c ;;;###autoload @@ -592,18 +259,12 @@ The return value of this function is a list of the read strings. See the documentation for `completing-read' for details on the arguments: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and INHERIT-INPUT-METHOD." - (let* ((minibuffer-completion-table (function crm-collection-fn)) + (let* ((minibuffer-completion-table #'crm--collection-fn) (minibuffer-completion-predicate predicate) ;; see completing_read in src/minibuf.c (minibuffer-completion-confirm (unless (eq require-match t) require-match)) (crm-completion-table table) - crm-last-exact-completion - crm-current-element - crm-left-of-element - crm-right-of-element - crm-beginning-of-element - crm-end-of-element (map (if require-match crm-local-must-match-map crm-local-completion-map)) @@ -615,6 +276,12 @@ INHERIT-INPUT-METHOD." (and def (string-equal input "") (setq input def)) (split-string input crm-separator))) +(define-obsolete-function-alias 'crm-minibuffer-complete 'crm-complete "23.1") +(define-obsolete-function-alias + 'crm-minibuffer-completion-help 'crm-completion-help "23.1") +(define-obsolete-function-alias + 'crm-minibuffer-complete-and-exit 'crm-complete-and-exit "23.1") + ;; testing and debugging ;; (defun crm-init-test-environ () ;; "Set up some variables for testing." @@ -637,5 +304,5 @@ INHERIT-INPUT-METHOD." (provide 'crm) -;;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6 +;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6 ;;; crm.el ends here diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el index 5c9a434ade0..6e81252f48a 100644 --- a/lisp/emacs-lisp/cust-print.el +++ b/lisp/emacs-lisp/cust-print.el @@ -13,10 +13,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -24,9 +24,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -244,14 +242,14 @@ Any pair that has the same PREDICATE is first removed." ;; Save emacs routines. (if (not (fboundp 'cust-print-original-prin1)) - (mapcar 'cust-print-set-function-cell - '((cust-print-original-prin1 prin1) - (cust-print-original-princ princ) - (cust-print-original-print print) - (cust-print-original-prin1-to-string prin1-to-string) - (cust-print-original-format format) - (cust-print-original-message message) - (cust-print-original-error error)))) + (mapc 'cust-print-set-function-cell + '((cust-print-original-prin1 prin1) + (cust-print-original-princ princ) + (cust-print-original-print print) + (cust-print-original-prin1-to-string prin1-to-string) + (cust-print-original-format format) + (cust-print-original-message message) + (cust-print-original-error error)))) (defun custom-print-install () @@ -259,29 +257,29 @@ Any pair that has the same PREDICATE is first removed." The Emacs subroutines are saved away, and you can reinstall them by running `custom-print-uninstall'." (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) + (mapc 'cust-print-set-function-cell + '((prin1 custom-prin1) + (princ custom-princ) + (print custom-print) + (prin1-to-string custom-prin1-to-string) + (format custom-format) + (message custom-message) + (error custom-error) + )) t) (defun custom-print-uninstall () "Reset print functions to their Emacs subroutines." (interactive) - (mapcar 'cust-print-set-function-cell - '((prin1 cust-print-original-prin1) - (princ cust-print-original-princ) - (print cust-print-original-print) - (prin1-to-string cust-print-original-prin1-to-string) - (format cust-print-original-format) - (message cust-print-original-message) - (error cust-print-original-error) - )) + (mapc 'cust-print-set-function-cell + '((prin1 cust-print-original-prin1) + (princ cust-print-original-princ) + (print cust-print-original-print) + (prin1-to-string cust-print-original-prin1-to-string) + (format cust-print-original-format) + (message cust-print-original-message) + (error cust-print-original-error) + )) t) (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p) @@ -689,5 +687,5 @@ See `custom-format' for the details." (provide 'cust-print) -;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580 +;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580 ;;; cust-print.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index c35142ce115..4a4d744b37f 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -232,9 +230,10 @@ first will be printed into the backtrace buffer." ;; would need to be de-iconified anyway immediately ;; after when we re-enter the debugger, so iconifying it ;; here would cause flashing. - ;; Use quit-window rather than bury-buffer to quieten - ;; Drew Adams. --Stef - (quit-window)))) + ;; Drew Adams is not happy with this: he wants to frame + ;; to be left at the top-level, still working on how + ;; best to do that. + (bury-buffer)))) (kill-buffer debugger-buffer)) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) @@ -585,7 +584,8 @@ Applies to the frame whose line point is on in the backtrace." (debugger-env-macro (eval-expression exp))) (defvar debugger-mode-map - (let ((map (make-keymap))) + (let ((map (make-keymap)) + (menu-map (make-sparse-keymap))) (set-keymap-parent map button-buffer-map) (suppress-keymap map) (define-key map "-" 'negative-argument) @@ -603,6 +603,49 @@ Applies to the frame whose line point is on in the backtrace." (define-key map "R" 'debugger-record-expression) (define-key map "\C-m" 'debug-help-follow) (define-key map [mouse-2] 'push-button) + (define-key map [menu-bar debugger] (cons "Debugger" menu-map)) + (define-key menu-map [deb-top] + '(menu-item "Quit" top-level + :help "Quit debugging and return to top level")) + (define-key menu-map [deb-s0] '("--")) + (define-key menu-map [deb-descr] + '(menu-item "Describe Debugger Mode" describe-mode + :help "Display documentation for debugger-mode")) + (define-key menu-map [deb-hfol] + '(menu-item "Help Follow" debug-help-follow + :help "Follow cross-reference")) + (define-key menu-map [deb-nxt] + '(menu-item "Next Line" next-line + :help "Move cursor down")) + (define-key menu-map [deb-s1] '("--")) + (define-key menu-map [deb-lfunc] + '(menu-item "List debug on entry functions" debugger-list-functions + :help "Display a list of all the functions now set to debug on entry")) + (define-key menu-map [deb-fclear] + '(menu-item "Cancel debug frame" debugger-frame-clear + :help "Do not enter debugger when this frame exits")) + (define-key menu-map [deb-frame] + '(menu-item "Debug frame" debugger-frame + :help "Request entry to debugger when this frame exits")) + (define-key menu-map [deb-s2] '("--")) + (define-key menu-map [deb-ret] + '(menu-item "Return value..." debugger-return-value + :help "Continue, specifying value to return.")) + (define-key menu-map [deb-rec] + '(menu-item "Display and Record Expression" debugger-record-expression + :help "Display a variable's value and record it in `*Backtrace-record*' buffer")) + (define-key menu-map [deb-eval] + '(menu-item "Eval Expression..." debugger-eval-expression + :help "Eval an expression, in an environment like that outside the debugger")) + (define-key menu-map [deb-jump] + '(menu-item "Jump" debugger-jump + :help "Continue to exit from this frame, with all debug-on-entry suspended")) + (define-key menu-map [deb-cont] + '(menu-item "Continue" debugger-continue + :help "Continue, evaluating this expression without stopping")) + (define-key menu-map [deb-step] + '(menu-item "Step through" debugger-step-through + :help "Proceed, stepping through subexpressions of this expression")) map)) (put 'debugger-mode 'mode-class 'special) @@ -655,6 +698,8 @@ Complete list of commands: (buffer-substring (line-beginning-position 0) (line-end-position 0))))) +(declare-function help-xref-interned "help-mode" (symbol)) + (defun debug-help-follow (&optional pos) "Follow cross-reference at POS, defaulting to point. diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 537309c8026..83cb7aeee78 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -164,7 +162,8 @@ The new mode runs the hook constructed by the function See Info node `(elisp)Derived Modes' for more details." (declare (debug (&define name symbolp sexp [&optional stringp] - [&rest keywordp sexp] def-body))) + [&rest keywordp sexp] def-body)) + (doc-string 4)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be @@ -254,11 +253,7 @@ No problems result if this variable is not bound. ,@body ) ;; Run the hooks, if any. - ;; Make the generated code work in older Emacs versions - ;; that do not yet have run-mode-hooks. - (if (fboundp 'run-mode-hooks) - (run-mode-hooks ',hook) - (run-hooks ',hook)))))) + (run-mode-hooks ',hook))))) ;; PUBLIC: find the ultimate class of a derived mode. diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 38862d389fd..d92c85092ef 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -250,7 +248,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(<byte code>...)\n") - (mapcar ;recurse on list of byte-code objects + (mapc ;recurse on list of byte-code objects '(lambda (obj) (disassemble-1 obj @@ -266,5 +264,5 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (provide 'disass) -;;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a +;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a ;;; disass.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index a19e2df3069..f2b467383d6 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -390,17 +388,18 @@ See `%s' for more information on %s." ;;; easy-mmode-defmap ;;; -(if (fboundp 'set-keymap-parents) - (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) - (defun easy-mmode-set-keymap-parents (m parents) - (set-keymap-parent - m - (cond - ((not (consp parents)) parents) - ((not (cdr parents)) (car parents)) - (t (let ((m (copy-keymap (pop parents)))) - (easy-mmode-set-keymap-parents m parents) - m)))))) +(eval-and-compile + (if (fboundp 'set-keymap-parents) + (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) + (defun easy-mmode-set-keymap-parents (m parents) + (set-keymap-parent + m + (cond + ((not (consp parents)) parents) + ((not (cdr parents)) (car parents)) + (t (let ((m (copy-keymap (pop parents)))) + (easy-mmode-set-keymap-parents m parents) + m))))))) ;;;###autoload (defun easy-mmode-define-keymap (bs &optional name m args) @@ -409,8 +408,17 @@ BS must be a list of (KEY . BINDING) where KEY and BINDINGS are suitable for `define-key'. Optional NAME is passed to `make-sparse-keymap'. Optional map M can be used to modify an existing map. -ARGS is a list of additional keyword arguments." - (let (inherit dense) +ARGS is a list of additional keyword arguments. + +Valid keywords and arguments are: + + :name Name of the keymap; overrides NAME argument. + :dense Non-nil for a dense keymap. + :inherit Parent keymap. + :group Ignored. + :suppress Non-nil to call `suppress-keymap' on keymap, + 'nodigits to suppress digits as prefix arguments." + (let (inherit dense suppress) (while args (let ((key (pop args)) (val (pop args))) @@ -418,11 +426,14 @@ ARGS is a list of additional keyword arguments." (:name (setq name val)) (:dense (setq dense val)) (:inherit (setq inherit val)) + (:suppress (setq suppress val)) (:group) (t (message "Unknown argument %s in defmap" key))))) (unless (keymapp m) (setq bs (append m bs)) (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) + (when suppress + (suppress-keymap m (eq suppress 'nodigits))) (dolist (b bs) (let ((keys (car b)) (binding (cdr b))) @@ -458,7 +469,7 @@ ARGS is a list of additional keyword arguments." (let ((char (car cs)) (syntax (cdr cs))) (if (sequencep char) - (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char) + (mapc (lambda (c) (modify-syntax-entry c syntax st)) char) (modify-syntax-entry char syntax st)))) (if parent (set-char-table-parent st (if (symbolp parent) (symbol-value parent) parent))) @@ -478,7 +489,8 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." ;;; easy-mmode-define-navigation ;;; -(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun) +(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun + &rest body) "Define BASE-next and BASE-prev to navigate in the buffer. RE determines the places the commands should move point to. NAME should describe the entities matched by RE. It is used to build @@ -488,17 +500,20 @@ BASE-next also tries to make sure that the whole entry is visible by the next entry) and recentering if necessary. ENDFUN should return the end position (with or without moving point). NARROWFUN non-nil means to check for narrowing before moving, and if -found, do `widen' first and then call NARROWFUN with no args after moving." +found, do `widen' first and then call NARROWFUN with no args after moving. +BODY is executed after moving to the destination location." + (declare (indent 5) (debug (exp exp exp def-form def-form &rest def-body))) (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next"))) - (check-narrow-maybe - (when narrowfun - '(setq was-narrowed - (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) - (widen))))) - (re-narrow-maybe (when narrowfun - `(when was-narrowed (,narrowfun))))) + (when-narrowed + (lambda (body) + (if (null narrowfun) body + `(let ((was-narrowed + (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) + (widen)))) + ,body + (when was-narrowed (,narrowfun))))))) (unless name (setq name base-name)) `(progn (add-to-list 'debug-ignored-errors @@ -509,33 +524,31 @@ found, do `widen' first and then call NARROWFUN with no args after moving." (unless count (setq count 1)) (if (< count 0) (,prev-sym (- count)) (if (looking-at ,re) (setq count (1+ count))) - (let (was-narrowed) - ,check-narrow-maybe - (if (not (re-search-forward ,re nil t count)) - (if (looking-at ,re) - (goto-char (or ,(if endfun `(,endfun)) (point-max))) - (error "No next %s" ,name)) - (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer (selected-window))) - (interactive-p)) - (let ((endpt (or (save-excursion - ,(if endfun `(,endfun) - `(re-search-forward ,re nil t 2))) - (point-max)))) - (unless (pos-visible-in-window-p endpt nil t) - (recenter '(0)))))) - ,re-narrow-maybe))) + ,(funcall when-narrowed + `(if (not (re-search-forward ,re nil t count)) + (if (looking-at ,re) + (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (error "No next %s" ,name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer (selected-window))) + (interactive-p)) + (let ((endpt (or (save-excursion + ,(if endfun `(,endfun) + `(re-search-forward ,re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (recenter '(0))))))) + ,@body)) (put ',next-sym 'definition-name ',base) (defun ,prev-sym (&optional count) ,(format "Go to the previous COUNT'th %s" (or name base-name)) (interactive "p") (unless count (setq count 1)) (if (< count 0) (,next-sym (- count)) - (let (was-narrowed) - ,check-narrow-maybe - (unless (re-search-backward ,re nil t count) - (error "No previous %s" ,name)) - ,re-narrow-maybe))) + ,(funcall when-narrowed + `(unless (re-search-backward ,re nil t count) + (error "No previous %s" ,name))) + ,@body)) (put ',prev-sym 'definition-name ',base)))) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 37083ac800a..bdca92e7fb0 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -116,10 +114,15 @@ whenever this expression's value is non-nil. INCLUDE is an expression; this item is only visible if this expression has a non-nil value. `:included' is an alias for `:visible'. + :label FORM + +FORM is an expression that will be dynamically evaluated and whose +value will be used for the menu entry's text label (the default is NAME). + :suffix FORM FORM is an expression that will be dynamically evaluated and whose -value will be concatenated to the menu entry's NAME. +value will be concatenated to the menu entry's label. :style STYLE @@ -152,6 +155,21 @@ A menu item can be a list with the same format as MENU. This is a submenu." ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) +(defun easy-menu-binding (menu &optional item-name) + "Return a binding suitable to pass to `define-key'. +This is expected to be bound to a mouse event." + ;; Under Emacs this is almost trivial, whereas under XEmacs this may + ;; involve defining a function that calls popup-menu. + (let ((props (if (symbolp menu) + (prog1 (get menu 'menu-prop) + (setq menu (symbol-function menu)))))) + (cons 'menu-item + (cons (or item-name + (if (keymapp menu) + (keymap-prompt menu)) + "") + (cons menu props))))) + ;;;###autoload (defun easy-menu-do-define (symbol maps doc menu) ;; We can't do anything that might differ between Emacs dialects in @@ -173,15 +191,10 @@ A menu item can be a list with the same format as MENU. This is a submenu." 'identity) (symbol-function ,symbol))) ,symbol))))) - (mapcar (lambda (map) - (define-key map (vector 'menu-bar (easy-menu-intern (car menu))) - (cons 'menu-item - (cons (car menu) - (if (not (symbolp keymap)) - (list keymap) - (cons (symbol-function keymap) - (get keymap 'menu-prop))))))) - (if (keymapp maps) (list maps) maps)))) + (dolist (map (if (keymapp maps) (list maps) maps)) + (define-key map + (vector 'menu-bar (easy-menu-intern (car menu))) + (easy-menu-binding keymap (car menu)))))) (defun easy-menu-filter-return (menu &optional name) "Convert MENU to the right thing to return from a menu filter. @@ -201,12 +214,18 @@ If NAME is provided, it is used for the keymap." (setq menu (cdr (easy-menu-convert-item menu))))) menu) +(defvar easy-menu-avoid-duplicate-keys t + "Dynamically scoped var to register already used keys in a menu. +If it holds a list, this is expected to be a list of keys already seen in the +menu we're processing. Else it means we're not processing a menu.") + ;;;###autoload (defun easy-menu-create-menu (menu-name menu-items) "Create a menu called MENU-NAME with items described in MENU-ITEMS. MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items possibly preceded by keyword pairs as described in `easy-menu-define'." (let ((menu (make-sparse-keymap menu-name)) + (easy-menu-avoid-duplicate-keys nil) prop keyword arg label enable filter visible help) ;; Look for keywords. (while (and menu-items @@ -249,10 +268,6 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (defvar easy-menu-button-prefix '((radio . :radio) (toggle . :toggle))) -(defun easy-menu-do-add-item (menu item &optional before) - (setq item (easy-menu-convert-item item)) - (easy-menu-define-key menu (easy-menu-intern (car item)) (cdr item) before)) - (defvar easy-menu-converted-items-table (make-hash-table :test 'equal)) (defun easy-menu-convert-item (item) @@ -262,14 +277,30 @@ conversion is done from within a filter. This also helps when the NAME of the entry is recreated each time: since the menu is built and traversed separately, the lookup would always fail because the key is `equal' but not `eq'." - (or (gethash item easy-menu-converted-items-table) - (puthash item (easy-menu-convert-item-1 item) - easy-menu-converted-items-table))) + (let* ((cache (gethash item easy-menu-converted-items-table)) + (result (or cache (easy-menu-convert-item-1 item))) + (key (car-safe result))) + (when (and (listp easy-menu-avoid-duplicate-keys) (symbolp key)) + ;; Merging multiple entries with the same name is sometimes what we + ;; want, but not when the entries are actually different (e.g. same + ;; name but different :suffix as seen in cal-menu.el) and appear in + ;; the same menu. So we try to detect and resolve conflicts. + (while (memq key easy-menu-avoid-duplicate-keys) + ;; We need to use some distinct object, ideally a symbol, ideally + ;; related to the `name'. Uninterned symbols do not work (they + ;; are apparently turned into strings and re-interned later on). + (setq key (intern (format "%s-%d" (symbol-name key) + (length easy-menu-avoid-duplicate-keys)))) + (setq result (cons key (cdr result)))) + (push key easy-menu-avoid-duplicate-keys)) + + (unless cache (puthash item result easy-menu-converted-items-table)) + result)) (defun easy-menu-convert-item-1 (item) "Parse an item description and convert it to a menu keymap element. ITEM defines an item as in `easy-menu-define'." - (let (name command label prop remove help) + (let (name command label prop remove) (cond ((stringp item) ; An item or separator. (setq label item)) @@ -330,22 +361,22 @@ ITEM defines an item as in `easy-menu-define'." (setq prop (cons :button (cons (cons (cdr style) selected) prop))))) (when (stringp keys) - (if (string-match "^[^\\]*\\(\\\\\\[\\([^]]+\\)]\\)[^\\]*$" - keys) - (let ((prefix - (if (< (match-beginning 0) (match-beginning 1)) - (substring keys 0 (match-beginning 1)))) - (postfix - (if (< (match-end 1) (match-end 0)) - (substring keys (match-end 1)))) - (cmd (intern (match-string 2 keys)))) - (setq keys (and (or prefix postfix) - (cons prefix postfix))) - (setq keys - (and (or keys (not (eq command cmd))) - (cons cmd keys)))) - (setq cache-specified nil)) - (if keys (setq prop (cons :keys (cons keys prop))))) + (if (string-match "^[^\\]*\\(\\\\\\[\\([^]]+\\)]\\)[^\\]*$" + keys) + (let ((prefix + (if (< (match-beginning 0) (match-beginning 1)) + (substring keys 0 (match-beginning 1)))) + (postfix + (if (< (match-end 1) (match-end 0)) + (substring keys (match-end 1)))) + (cmd (intern (match-string 2 keys)))) + (setq keys (and (or prefix postfix) + (cons prefix postfix))) + (setq keys + (and (or keys (not (eq command cmd))) + (cons cmd keys)))) + (setq cache-specified nil)) + (if keys (setq prop (cons :keys (cons keys prop))))) (if (and visible (not (easy-menu-always-true-p visible))) (if (equal visible ''nil) ;; Invisible menu item. Don't insert into keymap. @@ -360,12 +391,13 @@ ITEM defines an item as in `easy-menu-define'." ;; `intern' the name so as to merge multiple entries with the same name. ;; It also makes it easier/possible to lookup/change menu bindings ;; via keymap functions. - (cons (easy-menu-intern name) - (and (not remove) - (cons 'menu-item - (cons label - (and name - (cons command prop)))))))) + (let ((key (easy-menu-intern name))) + (cons key + (and (not remove) + (cons 'menu-item + (cons label + (and name + (cons command prop))))))))) (defun easy-menu-define-key (menu key item &optional before) "Add binding in MENU for KEY => ITEM. Similar to `define-key-after'. @@ -438,7 +470,10 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression (make-symbol (format "menu-function-%d" easy-menu-item-count)))) (setq easy-menu-item-count (1+ easy-menu-item-count)) (fset command - (if (or (keymapp callback) (functionp callback) noexp) callback + (if (or (keymapp callback) (commandp callback) + ;; `functionp' is probably not needed. + (functionp callback) noexp) + callback `(lambda () (interactive) ,callback))) command)) @@ -536,7 +571,8 @@ earlier by `easy-menu-define' or `easy-menu-create-menu'." (setq item (symbol-value item)))) ;; Item is a keymap, find the prompt string and use as item name. (setq item (cons (keymap-prompt item) item))) - (easy-menu-do-add-item map item before))) + (setq item (easy-menu-convert-item item)) + (easy-menu-define-key map (easy-menu-intern (car item)) (cdr item) before))) (defun easy-menu-item-present-p (map path name) "In submenu of MAP with path PATH, return non-nil if item NAME is present. @@ -615,7 +651,8 @@ In some cases we use that to select between the local and global maps." (catch 'found (if (and map (symbolp map) (not (keymapp map))) (setq map (symbol-value map))) - (let ((maps (if map (list map) (current-active-maps)))) + (let ((maps (if map (if (keymapp map) (list map) map) + (current-active-maps)))) ;; Look for PATH in each map. (unless map (push 'menu-bar path)) (dolist (name path) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index e825f2434b4..3395259a04f 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -66,7 +64,7 @@ (defcustom edebug-setup-hook nil - "*Functions to call before edebug is used. + "Functions to call before edebug is used. Each time it is set to a new value, Edebug will call those functions once and then `edebug-setup-hook' is reset to nil. You could use this to load up Edebug specifications associated with a package you are @@ -80,7 +78,7 @@ using but only when you also use Edebug." ;;;###autoload (defcustom edebug-all-defs nil - "*If non-nil, evaluating defining forms instruments for Edebug. + "If non-nil, evaluating defining forms instruments for Edebug. This applies to `eval-defun', `eval-region', `eval-buffer', and `eval-current-buffer'. `eval-region' is also called by `eval-last-sexp', and `eval-print-last-sexp'. @@ -98,14 +96,14 @@ variable. You may wish to make it local to each buffer with ;;;###autoload (defcustom edebug-all-forms nil - "*Non-nil evaluation of all forms will instrument for Edebug. + "Non-nil evaluation of all forms will instrument for Edebug. This doesn't apply to loading or evaluations in the minibuffer. Use the command `edebug-all-forms' to toggle the value of this option." :type 'boolean :group 'edebug) (defcustom edebug-eval-macro-args nil - "*Non-nil means all macro call arguments may be evaluated. + "Non-nil means all macro call arguments may be evaluated. If this variable is nil, the default, Edebug will *not* wrap macro call arguments as if they will be evaluated. For each macro, a `edebug-form-spec' overrides this option. @@ -115,7 +113,7 @@ and some not, you should specify an `edebug-form-spec'." :group 'edebug) (defcustom edebug-save-windows t - "*If non-nil, Edebug saves and restores the window configuration. + "If non-nil, Edebug saves and restores the window configuration. That takes some time, so if your program does not care what happens to the window configurations, it is better to set this variable to nil. @@ -127,7 +125,7 @@ restored. :group 'edebug) (defcustom edebug-save-displayed-buffer-points nil - "*If non-nil, save and restore point in all displayed buffers. + "If non-nil, save and restore point in all displayed buffers. Saving and restoring point in other buffers is necessary if you are debugging code that changes the point of a buffer which is displayed @@ -141,7 +139,7 @@ it." :group 'edebug) (defcustom edebug-initial-mode 'step - "*Initial execution mode for Edebug, if non-nil. + "Initial execution mode for Edebug, if non-nil. If this variable is non-nil, it specifies the initial execution mode for Edebug when it is first activated. Possible values are step, next, go, Go-nonstop, trace, Trace-fast, continue, and Continue-fast." @@ -152,7 +150,7 @@ go, Go-nonstop, trace, Trace-fast, continue, and Continue-fast." :group 'edebug) (defcustom edebug-trace nil - "*Non-nil means display a trace of function entry and exit. + "Non-nil means display a trace of function entry and exit. Tracing output is displayed in a buffer named `*edebug-trace*', one function entry or exit per line, indented by the recursion level. @@ -162,9 +160,9 @@ and `edebug-print-trace-after'." :group 'edebug) (defcustom edebug-test-coverage nil - "*If non-nil, Edebug tests coverage of all expressions debugged. -This is done by comparing the result of each expression -with the previous result. Coverage is considered OK if two different + "If non-nil, Edebug tests coverage of all expressions debugged. +This is done by comparing the result of each expression with the +previous result. Coverage is considered OK if two different results are found. Use `edebug-display-freq-count' to display the frequency count and @@ -173,27 +171,27 @@ coverage information for a definition." :group 'edebug) (defcustom edebug-continue-kbd-macro nil - "*If non-nil, continue defining or executing any keyboard macro. + "If non-nil, continue defining or executing any keyboard macro. Use this with caution since it is not debugged." :type 'boolean :group 'edebug) (defcustom edebug-print-length 50 - "*Default value of `print-length' for printing results in Edebug." + "Default value of `print-length' for printing results in Edebug." :type 'integer :group 'edebug) (defcustom edebug-print-level 50 - "*Default value of `print-level' for printing results in Edebug." + "Default value of `print-level' for printing results in Edebug." :type 'integer :group 'edebug) (defcustom edebug-print-circle t - "*Default value of `print-circle' for printing results in Edebug." + "Default value of `print-circle' for printing results in Edebug." :type 'boolean :group 'edebug) (defcustom edebug-unwrap-results nil - "*Non-nil if Edebug should unwrap results of expressions. + "Non-nil if Edebug should unwrap results of expressions. This is useful when debugging macros where the results of expressions are instrumented expressions. But don't do this when results might be circular or an infinite loop will result." @@ -201,7 +199,7 @@ circular or an infinite loop will result." :group 'edebug) (defcustom edebug-on-error t - "*Value bound to `debug-on-error' while Edebug is active. + "Value bound to `debug-on-error' while Edebug is active. If `debug-on-error' is non-nil, that value is still used. @@ -218,18 +216,18 @@ After execution is resumed, the error is signaled again." :group 'edebug) (defcustom edebug-on-quit t - "*Value bound to `debug-on-quit' while Edebug is active." + "Value bound to `debug-on-quit' while Edebug is active." :type 'boolean :group 'edebug) (defcustom edebug-global-break-condition nil - "*If non-nil, an expression to test for at every stop point. + "If non-nil, an expression to test for at every stop point. If the result is non-nil, then break. Errors are ignored." :type 'sexp :group 'edebug) (defcustom edebug-sit-for-seconds 1 - "*Number of seconds to pause when execution mode is `trace'." + "Number of seconds to pause when execution mode is `trace'." :type 'number :group 'edebug) @@ -273,8 +271,8 @@ An extant spec symbol is a symbol that is not a function and has a (defun edebug-gensym (&optional prefix) "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the -string that begins the new name. Most people take just the default, +There is an optional argument, PREFIX. PREFIX is the string +that begins the new name. Most people take just the default, except when debugging needs suggest otherwise." (if (null prefix) (setq prefix "G")) @@ -369,7 +367,7 @@ Return the result of the last expression in BODY." ;; Otherwise, find a new window, possibly splitting one. (setq window (cond - ((and (windowp window) (edebug-window-live-p window) + ((and (edebug-window-live-p window) (eq (window-buffer window) buffer)) window) ((eq (window-buffer (selected-window)) buffer) @@ -472,7 +470,7 @@ STREAM or the value of `standard-input' may be: a string (takes text from string, starting at the beginning) t (read text line using minibuffer and use it). -This version, from Edebug, maybe instruments the expression. But the +This version, from Edebug, maybe instruments the expression. But the STREAM must be the current buffer to do so. Whether it instruments is also dependent on the values of `edebug-all-defs' and `edebug-all-forms'." @@ -501,9 +499,9 @@ Setting `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is invoked without a prefix argument -If acting on a `defun' for FUNCTION, and the function was -instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not -instrumented, just FUNCTION is printed. +If acting on a `defun' for FUNCTION, and the function was instrumented, +`Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, +just FUNCTION is printed. If not acting on a `defun', the result of evaluation is displayed in the minibuffer." @@ -552,11 +550,11 @@ This is like `eval-defun' except that it steps the code for Edebug before evaluating it. It displays the value in the echo area using `eval-expression' (which see). -If you do this on a function definition -such as a defun or defmacro, it defines the function and instruments -its definition for Edebug, so it will do Edebug stepping when called -later. It displays `Edebug: FUNCTION' in the echo area to indicate -that FUNCTION is now instrumented for Edebug. +If you do this on a function definition such as a defun or defmacro, +it defines the function and instruments its definition for Edebug, +so it will do Edebug stepping when called later. It displays +`Edebug: FUNCTION' in the echo area to indicate that FUNCTION is now +instrumented for Edebug. If the current defun is actually a call to `defvar' or `defcustom', evaluating it this way resets the variable using its initial value @@ -1278,7 +1276,7 @@ expressions; a `progn' form will be returned enclosing these forms." sexp)) (defun edebug-unwrap* (sexp) - "Return the sexp recursively unwrapped." + "Return the SEXP recursively unwrapped." (let ((new-sexp (edebug-unwrap sexp))) (while (not (eq sexp new-sexp)) (setq sexp new-sexp @@ -2231,7 +2229,8 @@ See `condition-case'. This is the Edebug replacement for the standard `signal'. It should only be active while Edebug is. It checks `debug-on-error' to see whether it should call the debugger. When execution is resumed, the -error is signaled again." +error is signaled again. +\n(fn SIGNAL-NAME DATA)" (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error)) (edebug 'error (cons edebug-signal-name edebug-signal-data))) ;; If we reach here without another non-local exit, then send signal again. @@ -2342,7 +2341,7 @@ or nil (if the default binding is current)." (defun edebug-restore-status (var status) "Reset VAR based on STATUS. -STATUS should be a list you got from `edebug-var-status'." +STATUS should be a list returned by `edebug-var-status'." (let ((locus (car status)) (value (cdr status))) (cond ((bufferp locus) @@ -2739,7 +2738,7 @@ MSG is printed after `::::} '." ;; Unrestore edebug-buffer's window-start, if displayed. (let ((window (car edebug-window-data))) - (if (and window (edebug-window-live-p window) + (if (and (edebug-window-live-p window) (eq (window-buffer) edebug-buffer)) (progn (set-window-start window (cdr edebug-window-data) @@ -3295,12 +3294,12 @@ With prefix argument, make it a temporary breakpoint." (if (eq (1+ edebug-recursion-depth) (recursion-depth)) (progn (setq edebug-execution-mode mode) - (message shortmsg) + (message "%s" shortmsg) ;; Continue execution (exit-recursive-edit)) ;; This is not terribly useful!! (setq edebug-next-execution-mode mode) - (message msg))) + (message "%s" msg))) (defalias 'edebug-step-through-mode 'edebug-step-mode) @@ -3502,7 +3501,7 @@ Edebug, it calls `edebug-on-entry'." (defun edebug-top-level-nonstop () "Set mode to Go-nonstop, and exit to top-level. -This is useful for exiting even if unwind-protect code may be executed." +This is useful for exiting even if `unwind-protect' code may be executed." (interactive) (setq edebug-execution-mode 'Go-nonstop) (top-level)) @@ -3937,7 +3936,7 @@ edebug-global-break-condition ;; A list of expressions and their evaluations is displayed in *edebug*. (defun edebug-eval-result-list () - "Return a list of evaluations of edebug-eval-list" + "Return a list of evaluations of `edebug-eval-list'." ;; Assumes in outside environment. ;; Don't do any edebug things now. (let ((edebug-execution-mode 'Go-nonstop) @@ -3971,7 +3970,7 @@ edebug-global-break-condition ;; with calls in user functions, e.g. (edebug-eval-display) (defun edebug-eval-display (edebug-eval-result-list) - "Display expressions and evaluations in EVAL-LIST. + "Display expressions and evaluations in EDEBUG-EVAL-RESULT-LIST. It modifies the context by popping up the eval display." (if edebug-eval-result-list (progn @@ -3981,7 +3980,7 @@ It modifies the context by popping up the eval display." (defun edebug-eval-redisplay () "Redisplay eval list in outside environment. -May only be called from within edebug-recursive-edit." +May only be called from within `edebug-recursive-edit'." (edebug-create-eval-buffer) (edebug-outside-excursion (edebug-eval-display-list (edebug-eval-result-list)) @@ -4073,9 +4072,9 @@ Global commands prefixed by `global-edebug-prefix': ;; edebug is not dependent on this, yet. (defun edebug (&optional edebug-arg-mode &rest debugger-args) - "Replacement for debug. -If we are running an edebugged function, -show where we last were. Otherwise call debug normally." + "Replacement for `debug'. +If we are running an edebugged function, show where we last were. +Otherwise call `debug' normally." ;; (message "entered: %s depth: %s edebug-recursion-depth: %s" ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1) (if (and edebug-entered ; anything active? @@ -4175,7 +4174,7 @@ You must include newlines in FMT to break lines, but one newline is appended." (defun edebug-trace (fmt &rest args) - "Convenience call to edebug-trace-display using edebug-trace-buffer" + "Convenience call to `edebug-trace-display' using `edebug-trace-buffer'." (apply 'edebug-trace-display edebug-trace-buffer fmt args)) @@ -4183,8 +4182,8 @@ You must include newlines in FMT to break lines, but one newline is appended." (defun edebug-display-freq-count () "Display the frequency count data for each line of the current definition. -The frequency counts are inserted as comment lines after -each line, and you can undo all insertions with one `undo' command. +The frequency counts are inserted as comment lines after each line, +and you can undo all insertions with one `undo' command. The counts are inserted starting under the `(' before an expression or the `)' after an expression, or on the last char of a symbol. @@ -4389,7 +4388,7 @@ With prefix argument, make it a temporary breakpoint." (defun byte-compile-resolve-functions (funcs) "Say it is OK for the named functions to be unresolved." - (mapcar + (mapc (function (lambda (func) (setq byte-compile-unresolved-functions @@ -4478,5 +4477,5 @@ With prefix argument, make it a temporary breakpoint." (provide 'edebug) -;;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808 +;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808 ;;; edebug.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index e184d106ae7..710ff821f1d 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -101,6 +99,11 @@ truncated to make more of the arglist or documentation string visible." enable argument list to fit on one line" truncate-sym-name-if-fit)) :group 'eldoc) +(defface eldoc-highlight-function-argument + '((t (:inherit bold))) + "Face used for the argument at point in a function's argument list." + :group 'eldoc) + ;;; No user options below here. (defvar eldoc-message-commands-table-size 31 @@ -124,8 +127,8 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") (defconst eldoc-last-data (make-vector 3 nil) "Bookkeeping; elements are as follows: 0 - contains the last symbol read from the buffer. - 1 - contains the string last displayed in the echo area for that - symbol, so it can be printed again if necessary without reconsing. + 1 - contains the string last displayed in the echo area for variables, + or argument string for functions. 2 - 'function if function args, 'variable if variable documentation.") (defvar eldoc-last-message nil) @@ -249,37 +252,93 @@ Emacs Lisp mode) that support Eldoc.") (let* ((current-symbol (eldoc-current-symbol)) (current-fnsym (eldoc-fnsym-in-current-sexp)) (doc (cond - ((eq current-symbol current-fnsym) - (or (eldoc-get-fnsym-args-string current-fnsym) + ((null current-fnsym) + nil) + ((eq current-symbol (car current-fnsym)) + (or (apply 'eldoc-get-fnsym-args-string + current-fnsym) (eldoc-get-var-docstring current-symbol))) (t (or (eldoc-get-var-docstring current-symbol) - (eldoc-get-fnsym-args-string current-fnsym)))))) + (apply 'eldoc-get-fnsym-args-string + current-fnsym)))))) (eldoc-message doc)))) ;; This is run from post-command-hook or some idle timer thing, ;; so we need to be careful that errors aren't ignored. (error (message "eldoc error: %s" err)))) -;; Return a string containing the function parameter list, or 1-line -;; docstring if function is a subr and no arglist is obtainable from the -;; docstring or elsewhere. -(defun eldoc-get-fnsym-args-string (sym) - (let ((args nil) - (doc nil)) +(defun eldoc-get-fnsym-args-string (sym &optional index) + "Return a string containing the parameter list of the function SYM. +If SYM is a subr and no arglist is obtainable from the docstring +or elsewhere, return a 1-line docstring. Calls the functions +`eldoc-function-argstring-format' and +`eldoc-highlight-function-argument' to format the result. The +former calls `eldoc-argument-case'; the latter gives the +function name `font-lock-function-name-face', and optionally +highlights argument number INDEX. " + (let (args doc) (cond ((not (and sym (symbolp sym) (fboundp sym)))) - ((and (eq sym (aref eldoc-last-data 0)) - (eq 'function (aref eldoc-last-data 2))) - (setq doc (aref eldoc-last-data 1))) + ((and (eq sym (aref eldoc-last-data 0)) + (eq 'function (aref eldoc-last-data 2))) + (setq doc (aref eldoc-last-data 1))) ((setq doc (help-split-fundoc (documentation sym t) sym)) (setq args (car doc)) + ;; Remove any enclosing (), since e-function-argstring adds them. (string-match "\\`[^ )]* ?" args) - (setq args (concat "(" (substring args (match-end 0))))) - (t - (setq args (eldoc-function-argstring sym)))) - (cond (args - (setq doc (eldoc-docstring-format-sym-doc sym args)) - (eldoc-last-data-store sym doc 'function))) - doc)) + (setq args (substring args (match-end 0))) + (if (string-match ")\\'" args) + (setq args (substring args 0 -1)))) + (t + (setq args (help-function-arglist sym)))) + (if args + ;; Stringify, and store before highlighting, downcasing, etc. + ;; FIXME should truncate before storing. + (eldoc-last-data-store sym (setq args (eldoc-function-argstring args)) + 'function) + (setq args doc)) ; use stored value + ;; Change case, highlight, truncate. + (if args + (eldoc-highlight-function-argument + sym (eldoc-function-argstring-format args) index)))) + +(defun eldoc-highlight-function-argument (sym args index) + "Highlight argument INDEX in ARGS list for function SYM. +In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." + (let ((start nil) + (end 0) + (argument-face 'eldoc-highlight-function-argument)) + ;; Find the current argument in the argument string. We need to + ;; handle `&rest' and informal `...' properly. + ;; + ;; FIXME: What to do with optional arguments, like in + ;; (defun NAME ARGLIST [DOCSTRING] BODY...) case? + ;; The problem is there is no robust way to determine if + ;; the current argument is indeed a docstring. + (while (and index (>= index 1)) + (if (string-match "[^ ()]+" args end) + (progn + (setq start (match-beginning 0) + end (match-end 0)) + (let ((argument (match-string 0 args))) + (cond ((string= argument "&rest") + ;; All the rest arguments are the same. + (setq index 1)) + ((string= argument "&optional")) + ((string-match "\\.\\.\\.$" argument) + (setq index 0)) + (t + (setq index (1- index)))))) + (setq end (length args) + start (1- end) + argument-face 'font-lock-warning-face + index 0))) + (let ((doc args)) + (when start + (setq doc (copy-sequence args)) + (add-text-properties start end (list 'face argument-face) doc)) + (setq doc (eldoc-docstring-format-sym-doc + sym doc 'font-lock-function-name-face)) + doc))) ;; Return a string containing a brief (one-line) documentation string for ;; the variable. @@ -292,7 +351,8 @@ Emacs Lisp mode) that support Eldoc.") (let ((doc (documentation-property sym 'variable-documentation t))) (cond (doc (setq doc (eldoc-docstring-format-sym-doc - sym (eldoc-docstring-first-line doc))) + sym (eldoc-docstring-first-line doc) + 'font-lock-variable-name-face)) (eldoc-last-data-store sym doc 'variable))) doc))))) @@ -316,7 +376,7 @@ Emacs Lisp mode) that support Eldoc.") ;; If the entire line cannot fit in the echo area, the symbol name may be ;; truncated or eliminated entirely from the output to make room for the ;; description. -(defun eldoc-docstring-format-sym-doc (sym doc) +(defun eldoc-docstring-format-sym-doc (sym doc face) (save-match-data (let* ((name (symbol-name sym)) (ea-multi eldoc-echo-area-use-multiline-p) @@ -328,7 +388,7 @@ Emacs Lisp mode) that support Eldoc.") (cond ((or (<= strip 0) (eq ea-multi t) (and ea-multi (> (length doc) ea-width))) - (format "%s: %s" sym doc)) + (format "%s: %s" (propertize name 'face face) doc)) ((> (length doc) ea-width) (substring (format "%s" doc) 0 ea-width)) ((>= strip (length name)) @@ -338,27 +398,44 @@ Emacs Lisp mode) that support Eldoc.") ;; than the beginning, since the former is more likely ;; to be unique given package namespace conventions. (setq name (substring name strip)) - (format "%s: %s" name doc)))))) + (format "%s: %s" (propertize name 'face face) doc)))))) +;; Return a list of current function name and argument index. (defun eldoc-fnsym-in-current-sexp () - (let ((p (point))) - (eldoc-beginning-of-sexp) - (prog1 - ;; Don't do anything if current word is inside a string. - (if (= (or (char-after (1- (point))) 0) ?\") - nil - (eldoc-current-symbol)) - (goto-char p)))) - + (save-excursion + (let ((argument-index (1- (eldoc-beginning-of-sexp)))) + ;; If we are at the beginning of function name, this will be -1. + (when (< argument-index 0) + (setq argument-index 0)) + ;; Don't do anything if current word is inside a string. + (if (= (or (char-after (1- (point))) 0) ?\") + nil + (list (eldoc-current-symbol) argument-index))))) + +;; Move to the beginnig of current sexp. Return the number of nested +;; sexp the point was over or after. (defun eldoc-beginning-of-sexp () - (let ((parse-sexp-ignore-comments t)) + (let ((parse-sexp-ignore-comments t) + (num-skipped-sexps 0)) (condition-case err - (while (progn - (forward-sexp -1) - (or (= (char-before) ?\") - (> (point) (point-min))))) - (error nil)))) + (progn + ;; First account for the case the point is directly over a + ;; beginning of a nested sexp. + (condition-case err + (let ((p (point))) + (forward-sexp -1) + (forward-sexp 1) + (when (< (point) p) + (setq num-skipped-sexps 1))) + (error)) + (while + (let ((p (point))) + (forward-sexp -1) + (when (< (point) p) + (setq num-skipped-sexps (1+ num-skipped-sexps)))))) + (error)) + num-skipped-sexps)) ;; returns nil unless current word is an interned symbol. (defun eldoc-current-symbol () @@ -377,28 +454,31 @@ Emacs Lisp mode) that support Eldoc.") (error (setq defn nil)))) defn)) -(defun eldoc-function-argstring (fn) - (eldoc-function-argstring-format (help-function-arglist fn))) - -(defun eldoc-function-argstring-format (arglist) - (cond ((not (listp arglist)) - (setq arglist nil)) - ((symbolp (car arglist)) - (setq arglist - (mapcar (function (lambda (s) - (if (memq s '(&optional &rest)) - (symbol-name s) - (funcall eldoc-argument-case - (symbol-name s))))) - arglist))) - ((stringp (car arglist)) - (setq arglist - (mapcar (function (lambda (s) - (if (member s '("&optional" "&rest")) - s - (funcall eldoc-argument-case s)))) - arglist)))) - (concat "(" (mapconcat 'identity arglist " ") ")")) +(defun eldoc-function-argstring (arglist) + "Return ARGLIST as a string enclosed by (). +ARGLIST is either a string, or a list of strings or symbols." + (cond ((stringp arglist)) + ((not (listp arglist)) + (setq arglist nil)) + ((symbolp (car arglist)) + (setq arglist + (mapconcat (lambda (s) (symbol-name s)) + arglist " "))) + ((stringp (car arglist)) + (setq arglist + (mapconcat (lambda (s) s) + arglist " ")))) + (if arglist + (format "(%s)" arglist))) + +(defun eldoc-function-argstring-format (argstring) + "Apply `eldoc-argument-case' to each word in ARGSTRING. +The words \"&rest\", \"&optional\" are returned unchanged." + (mapconcat (lambda (s) + (if (member s '("&optional" "&rest")) + s + (funcall eldoc-argument-case s))) + (split-string argstring "[][ ()]+" t) " ")) ;; When point is in a sexp, the function args are not reprinted in the echo diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 7284e1c9c16..fe1bf219b16 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -218,7 +216,7 @@ This environment can be passed to `macroexpand'." (buffer-file-name) (buffer-name)))) (elint-display-log) - (mapcar 'elint-top-form (elint-update-env)) + (mapc 'elint-top-form (elint-update-env)) ;; Tell the user we're finished. This is terribly klugy: we set ;; elint-top-form-logged so elint-log-message doesn't print the @@ -542,11 +540,11 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (defun elint-check-defun-form (form env) "Lint a defun/defmacro/lambda FORM in ENV." (setq form (if (eq (car form) 'lambda) (cdr form) (cdr (cdr form)))) - (mapcar (function (lambda (p) - (or (memq p '(&optional &rest)) - (setq env (elint-env-add-var env p))) - )) - (car form)) + (mapc (function (lambda (p) + (or (memq p '(&optional &rest)) + (setq env (elint-env-add-var env p))) + )) + (car form)) (elint-forms (cdr form) env)) (defun elint-check-let-form (form env) @@ -566,21 +564,21 @@ CODE can be a lambda expression, a macro, or byte-compiled code." ;; Add variables to environment, and check the init values (let ((newenv env)) - (mapcar (function (lambda (s) - (cond - ((symbolp s) - (setq newenv (elint-env-add-var newenv s))) - ((and (consp s) (<= (length s) 2)) - (elint-form (car (cdr s)) - (if (eq (car form) 'let) - env - newenv)) - (setq newenv - (elint-env-add-var newenv (car s)))) - (t (elint-error - "Malformed `let' declaration: %s" s)) - ))) - varlist) + (mapc (function (lambda (s) + (cond + ((symbolp s) + (setq newenv (elint-env-add-var newenv s))) + ((and (consp s) (<= (length s) 2)) + (elint-form (car (cdr s)) + (if (eq (car form) 'let) + env + newenv)) + (setq newenv + (elint-env-add-var newenv (car s)))) + (t (elint-error + "Malformed `let' declaration: %s" s)) + ))) + varlist) ;; Lint the body forms (elint-forms (cdr (cdr form)) newenv) @@ -665,18 +663,18 @@ CODE can be a lambda expression, a macro, or byte-compiled code." errlist) (while errforms (setq errlist (car (car errforms))) - (mapcar (function (lambda (s) - (or (get s 'error-conditions) - (get s 'error-message) - (elint-warning - "Not an error symbol in error handler: %s" s)))) - (cond - ((symbolp errlist) (list errlist)) - ((listp errlist) errlist) - (t (elint-error "Bad error list in error handler: %s" - errlist) - nil)) - ) + (mapc (function (lambda (s) + (or (get s 'error-conditions) + (get s 'error-message) + (elint-warning + "Not an error symbol in error handler: %s" s)))) + (cond + ((symbolp errlist) (list errlist)) + ((listp errlist) errlist) + (t (elint-error "Bad error list in error handler: %s" + errlist) + nil)) + ) (elint-forms (cdr (car errforms)) newenv) (setq errforms (cdr errforms)) ))) @@ -767,11 +765,11 @@ Insert HEADER followed by a blank line if non-nil." (defun elint-initialize () "Initialize elint." (interactive) - (mapcar (function (lambda (x) - (or (not (symbolp (car x))) - (eq (cdr x) 'unknown) - (put (car x) 'elint-args (cdr x))))) - (elint-find-builtin-args)) + (mapc (function (lambda (x) + (or (not (symbolp (car x))) + (eq (cdr x) 'unknown) + (put (car x) 'elint-args (cdr x))))) + (elint-find-builtin-args)) (mapcar (function (lambda (x) (put (car x) 'elint-args (cdr x)))) elint-unknown-builtin-args)) @@ -806,5 +804,5 @@ If no documentation could be found args will be `unknown'." (provide 'elint) -;;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f +;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f ;;; elint.el ends here diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 12332f03e64..53eeea144cc 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; @@ -596,39 +594,61 @@ displayed." symname))))) elp-all-instrumented-list)) ) ; end let* - (insert title) - (if (> longest titlelen) - (progn - (insert-char 32 (- longest titlelen)) - (setq elp-field-len longest))) - (insert " " cc-header " " et-header " " at-header "\n") - (insert-char ?= elp-field-len) - (insert " ") - (insert-char ?= elp-cc-len) - (insert " ") - (insert-char ?= elp-et-len) - (insert " ") - (insert-char ?= elp-at-len) - (insert "\n") + ;; If printing to stdout, insert the header so it will print. + ;; Otherwise use header-line-format. + (setq elp-field-len (max titlelen longest)) + (if (or elp-use-standard-output noninteractive) + (progn + (insert title) + (if (> longest titlelen) + (progn + (insert-char 32 (- longest titlelen)))) + (insert " " cc-header " " et-header " " at-header "\n") + (insert-char ?= elp-field-len) + (insert " ") + (insert-char ?= elp-cc-len) + (insert " ") + (insert-char ?= elp-et-len) + (insert " ") + (insert-char ?= elp-at-len) + (insert "\n")) + (let ((column 0)) + (setq header-line-format + (mapconcat + (lambda (title) + (prog1 + (concat + (propertize " " + 'display (list 'space :align-to column) + 'face 'fixed-pitch) + title) + (setq column (+ column 1 + (if (= column 0) + elp-field-len + (length title)))))) + (list title cc-header et-header at-header) "")))) ;; if sorting is enabled, then sort the results list. in either ;; case, call elp-output-result to output the result in the ;; buffer (if elp-sort-by-function (setq resvec (sort resvec elp-sort-by-function))) - (mapcar 'elp-output-result resvec)) + (mapc 'elp-output-result resvec)) ;; now pop up results buffer (set-buffer curbuf) (pop-to-buffer resultsbuf) ;; copy results to standard-output? (if (or elp-use-standard-output noninteractive) - (princ (buffer-substring (point-min) (point-max)))) + (princ (buffer-substring (point-min) (point-max))) + (goto-char (point-min))) ;; reset profiling info if desired (and elp-reset-after-results (elp-reset-all)))) -(defun elp-unload-hook () - (elp-restore-all)) -(add-hook 'elp-unload-hook 'elp-unload-hook) +(defun elp-unload-function () + "Unload the Emacs Lisp Profiler." + (elp-restore-all) + ;; continue standard unloading + nil) (provide 'elp) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index b21ec5e9c85..e24cac3eb5d 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -11,10 +11,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -22,9 +22,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -54,7 +52,7 @@ ;; dll (a doubly linked list) and the contents of a buffer. ;; Possible uses are dired (have all files in a list, and show them), ;; buffer-list, kom-prioritize (in the LysKOM elisp client) and -;; others. pcl-cvs.el uses ewoc.el. +;; others. pcl-cvs.el and vc.el use ewoc.el. ;; ;; Ewoc can be considered as the `view' part of a model-view-controller. ;; @@ -547,7 +545,7 @@ remaining arguments will be passed to PREDICATE." (if (apply predicate (ewoc--node-data node) args) (push (ewoc--node-data node) result)) (setq node (ewoc--node-prev dll node))) - (nreverse result))) + result)) (defun ewoc-buffer (ewoc) "Return the buffer that is associated with EWOC. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 2022d3ab7d4..efae0d1cdc8 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; @@ -46,8 +44,6 @@ ;;; Code: -(require 'loadhist) - ;;; User variables: (defgroup find-function nil @@ -152,10 +148,14 @@ See the functions `find-function' and `find-variable'." ;; the same name. (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) - (or (locate-file library - (or find-function-source-path load-path) - (append (find-library-suffixes) load-file-rep-suffixes)) - (error "Can't find library %s" library))) + (or + (locate-file library + (or find-function-source-path load-path) + (find-library-suffixes)) + (locate-file library + (or find-function-source-path load-path) + load-file-rep-suffixes) + (error "Can't find library %s" library))) (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) @@ -195,21 +195,31 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (defun find-library (library) "Find the elisp source of LIBRARY." (interactive - (let* ((path (cons (or find-function-source-path load-path) - (find-library-suffixes))) + (let* ((dirs (or find-function-source-path load-path)) + (suffixes (find-library-suffixes)) (def (if (eq (function-called-at-point) 'require) - (save-excursion - (backward-up-list) - (forward-char) - (backward-sexp -2) - (thing-at-point 'symbol)) + ;; `function-called-at-point' may return 'require + ;; with `point' anywhere on this line. So wrap the + ;; `save-excursion' below in a `condition-case' to + ;; avoid reporting a scan-error here. + (condition-case nil + (save-excursion + (backward-up-list) + (forward-char) + (forward-sexp 2) + (thing-at-point 'symbol)) + (error nil)) (thing-at-point 'symbol)))) (when def - (setq def (and (locate-file-completion def path 'test) def))) + (setq def (and (locate-file-completion-table + dirs suffixes def nil 'lambda) + def))) (list (completing-read (if def (format "Library name (default %s): " def) "Library name: ") - 'locate-file-completion path nil nil nil def)))) + (apply-partially 'locate-file-completion-table + dirs suffixes) + 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 cf9abf57244..06baa96144d 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -18,9 +18,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -162,5 +160,5 @@ Also store it in `find-gc-unsafe'." (provide 'find-gc) -;;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 +;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 ;;; find-gc.el ends here diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 299743cfe7d..5ba2405f3ae 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -58,5 +56,5 @@ (provide 'lisp-float-type) -;;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d +;; 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 cc295c7ce3e..a60f6e342c0 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -205,7 +203,7 @@ See the file generic-x.el for some examples of `define-generic-mode'." (setq font-lock-defaults '(generic-font-lock-keywords)) ;; Call a list of functions - (mapcar 'funcall function-list) + (mapc 'funcall function-list) (run-mode-hooks mode-hook))) @@ -240,9 +238,9 @@ Some generic modes are defined in `generic-x.el'." (when (consp start) (setq end (cdr start)) (setq start (car start))) - (when (char-valid-p start) (setq start (char-to-string start))) + (when (characterp start) (setq start (char-to-string start))) (cond - ((char-valid-p end) (setq end (char-to-string end))) + ((characterp end) (setq end (char-to-string end))) ((zerop (length end)) (setq end "\n"))) ;; Setup the vars for `comment-region' diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index 873352a4aea..1474e3cd7a7 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -78,6 +76,9 @@ Thanks.") :type 'string :group 'gulp) +(declare-function mail-subject "sendmail" ()) +(declare-function mail-send "sendmail" ()) + (defun gulp-send-requests (dir &optional time) "Send requests for updates to the authors of Lisp packages in directory DIR. For each maintainer, the message consists of `gulp-request-header', @@ -174,5 +175,5 @@ That is a list of elements, each of the form (MAINTAINER PACKAGES...)." (provide 'gulp) -;;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5 +;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5 ;;; gulp.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index f0bac8f7bdf..68d314fd07f 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -120,10 +118,9 @@ (defun Helper-describe-mode () "Describe the current mode." (interactive) - (let ((name mode-name) + (let ((name (format-mode-line mode-name)) (documentation (documentation major-mode))) - (save-excursion - (set-buffer (get-buffer-create "*Help*")) + (with-current-buffer (get-buffer-create "*Help*") (setq buffer-read-only nil) (erase-buffer) (insert name " Mode\n" documentation) @@ -158,5 +155,5 @@ (provide 'helper) -;;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9 +;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9 ;;; helper.el ends here diff --git a/lisp/emacs-lisp/levents.el b/lisp/emacs-lisp/levents.el index 99eeb7dfe07..3724729bcd2 100644 --- a/lisp/emacs-lisp/levents.el +++ b/lisp/emacs-lisp/levents.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -291,5 +289,5 @@ GNU Emacs 19 does not currently generate process-output events." (provide 'levents) -;;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525 +;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525 ;;; levents.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 62f47471404..ba70bda9589 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -11,10 +11,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -22,9 +22,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -37,7 +35,8 @@ ;; Another entry point automatically addresses bug mail to a package's ;; maintainer or author. -;; This file can be loaded by your lisp-mode-hook. Have it (require 'lisp-mnt) +;; This file can be loaded by your emacs-lisp-mode-hook. Have it +;; (require 'lisp-mnt) ;; This file is an example of the header conventions. Note the following ;; features: @@ -76,8 +75,7 @@ ;; ;; * Maintainer line --- should be a single name/address as in the Author ;; line, or an address only, or the string "FSF". If there is no maintainer -;; line, the person(s) in the Author field are presumed to be it. The example -;; in this file is mildly bogus because the maintainer line is redundant. +;; line, the person(s) in the Author field are presumed to be it. ;; The idea behind these two fields is to be able to write a Lisp function ;; that does "send mail to the author" without having to mine the name out by ;; hand. Please be careful about surrounding the network address with <> if @@ -95,8 +93,8 @@ ;; package for the distribution. (This file doesn't have one because the ;; author *is* one of the maintainers.) ;; -;; * Keywords line --- used by the finder code (now under construction) -;; for finding Emacs Lisp code related to a topic. +;; * Keywords line --- used by the finder code for finding Emacs +;; Lisp code related to a topic. ;; ;; * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example ;; of a comment header. Headers starting with `X-' should never be used @@ -305,12 +303,12 @@ If FILE is nil, execute BODY in the current buffer." (if ,filesym (with-temp-buffer (insert-file-contents ,filesym) - (lisp-mode) + (emacs-lisp-mode) ,@body) (save-excursion ;; Switching major modes is too drastic, so just switch - ;; temporarily to the Lisp mode syntax table. - (with-syntax-table lisp-mode-syntax-table + ;; temporarily to the Emacs Lisp mode syntax table. + (with-syntax-table emacs-lisp-mode-syntax-table ,@body)))))) (put 'lm-with-file 'lisp-indent-function 1) @@ -511,18 +509,17 @@ copyright notice is allowed." (if (and file (file-directory-p file)) (setq ret (with-temp-buffer - (mapcar - (lambda (f) - (if (string-match ".*\\.el\\'" f) - (let ((status (lm-verify f))) - (insert f ":") - (if status - (lm-insert-at-column lm-comment-column status - "\n") - (if showok - (lm-insert-at-column lm-comment-column - "OK\n")))))) - (directory-files file)))) + (dolist (f (directory-files file nil "\\.el\\'") + (buffer-string)) + (when (file-regular-p f) + (let ((status (lm-verify f))) + (insert f ":") + (if status + (lm-insert-at-column lm-comment-column status + "\n") + (if showok + (lm-insert-at-column lm-comment-column + "OK\n")))))))) (lm-with-file file (setq name (lm-get-package-name)) (setq ret @@ -562,7 +559,7 @@ copyright notice is allowed." (t ret))))) (if verbose - (message ret)) + (message "%s" ret)) ret)) (defun lm-synopsis (&optional file showall) @@ -591,7 +588,7 @@ which do not include a recognizable synopsis." (lm-summary)) (when must-kill (kill-buffer (current-buffer)))))))) -(eval-when-compile (defvar report-emacs-bug-address)) +(defvar report-emacs-bug-address) (defun lm-report-bug (topic) "Report a bug in the package currently being visited to its maintainer. @@ -615,5 +612,5 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (provide 'lisp-mnt) -;;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e +;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e ;;; lisp-mnt.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index e930987e7e6..011f1f57dff 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -37,6 +35,8 @@ (defvar lisp-mode-abbrev-table nil) +(define-abbrev-table 'lisp-mode-abbrev-table ()) + (defvar emacs-lisp-mode-syntax-table (let ((table (make-syntax-table))) (let ((i 0)) @@ -56,6 +56,8 @@ (modify-syntax-entry i "_ " table) (setq i (1+ i))) (modify-syntax-entry ?\s " " table) + ;; Non-break space acts as whitespace. + (modify-syntax-entry ?\x8a0 " " table) (modify-syntax-entry ?\t " " table) (modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\n "> " table) @@ -86,8 +88,6 @@ (modify-syntax-entry ?| "\" 23bn" table) table)) -(define-abbrev-table 'lisp-mode-abbrev-table ()) - (defvar lisp-imenu-generic-expression (list (list nil @@ -214,8 +214,6 @@ ;;(set (make-local-variable 'adaptive-fill-mode) nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'lisp-indent-region) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (make-local-variable 'outline-regexp) @@ -259,7 +257,6 @@ (defvar lisp-mode-shared-map (let ((map (make-sparse-keymap))) - (define-key map "\t" 'lisp-indent-line) (define-key map "\e\C-q" 'indent-sexp) (define-key map "\177" 'backward-delete-char-untabify) ;; This gets in the way when viewing a Lisp file in view-mode. As @@ -269,41 +266,109 @@ map) "Keymap for commands shared by all sorts of Lisp modes.") -(defvar emacs-lisp-mode-map () +(defvar emacs-lisp-mode-map + (let ((map (make-sparse-keymap "Emacs-Lisp")) + (menu-map (make-sparse-keymap "Emacs-Lisp")) + (prof-map (make-sparse-keymap)) + (tracing-map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map "\e\t" 'lisp-complete-symbol) + (define-key map "\e\C-x" 'eval-defun) + (define-key map "\e\C-q" 'indent-pp-sexp) + (define-key map [menu-bar emacs-lisp] (cons "Emacs-Lisp" menu-map)) + (define-key menu-map [eldoc] + '(menu-item "Auto-Display Documentation Strings" eldoc-mode + :button (:toggle . (bound-and-true-p eldoc-mode)) + :help "Display the documentation string for the item under cursor")) + (define-key menu-map [checkdoc] + '(menu-item "Check Documentation Strings" checkdoc + :help "Check documentation strings for style requirements")) + (define-key menu-map [re-builder] + '(menu-item "Construct Regexp" re-builder + :help "Construct a regexp interactively")) + (define-key menu-map [tracing] (cons "Tracing" tracing-map)) + (define-key tracing-map [tr-a] + '(menu-item "Untrace all" untrace-all + :help "Untraces all currently traced functions")) + (define-key tracing-map [tr-uf] + '(menu-item "Untrace function..." untrace-function + :help "Untraces FUNCTION and possibly activates all remaining advice")) + (define-key tracing-map [tr-sep] '("--")) + (define-key tracing-map [tr-q] + '(menu-item "Trace function quietly..." trace-function-background + :help "Trace the function with trace output going quietly to a buffer")) + (define-key tracing-map [tr-f] + '(menu-item "Trace function..." trace-function + :help "Trace the function given as a argument")) + (define-key menu-map [profiling] (cons "Profiling" prof-map)) + (define-key prof-map [prof-restall] + '(menu-item "Remove Instrumentation for All Functions" elp-restore-all + :help "Restore the original definitions of all functions being profiled")) + (define-key prof-map [prof-restfunc] + '(menu-item "Remove Instrumentation for Function..." elp-restore-function + :help "Restore an instrumented function to its original definition")) + + (define-key prof-map [sep-rem] '("--")) + (define-key prof-map [prof-resall] + '(menu-item "Reset Counters for All Functions" elp-reset-all + :help "Reset the profiling information for all functions being profiled")) + (define-key prof-map [prof-resfunc] + '(menu-item "Reset Counters for Function..." elp-reset-function + :help "Reset the profiling information for a function")) + (define-key prof-map [prof-res] + '(menu-item "Show Profiling Results" elp-results + :help "Display current profiling results")) + (define-key prof-map [prof-pack] + '(menu-item "Instrument Package..." elp-instrument-package + :help "Instrument for profiling all function that start with a prefix")) + (define-key prof-map [prof-func] + '(menu-item "Instrument Function..." elp-instrument-function + :help "Instrument a function for profiling")) + (define-key menu-map [edebug-defun] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (define-key menu-map [separator-byte] '("--")) + (define-key menu-map [disas] + '(menu-item "Disassemble byte compiled object..." disassemble + :help "Print disassembled code for OBJECT in a buffer")) + (define-key menu-map [byte-recompile] + '(menu-item "Byte-recompile Directory..." byte-recompile-directory + :help "Recompile every `.el' file in DIRECTORY that needs recompilation")) + (define-key menu-map [emacs-byte-compile-and-load] + '(menu-item "Byte-compile And Load" emacs-lisp-byte-compile-and-load + :help "Byte-compile the current file (if it has changed), then load compiled code")) + (define-key menu-map [byte-compile] + '(menu-item "Byte-compile This File" emacs-lisp-byte-compile + :help "Byte compile the file containing the current buffer")) + (define-key menu-map [separator-eval] '("--")) + (define-key menu-map [ielm] + '(menu-item "Interactive Expression Evaluation" ielm + :help "Interactively evaluate Emacs Lisp expressions")) + (define-key menu-map [eval-buffer] + '(menu-item "Evaluate Buffer" eval-buffer + :help "Execute the current buffer as Lisp code")) + (define-key menu-map [eval-region] + '(menu-item "Evaluate Region" eval-region + :help "Execute the region as Lisp code" + :enable mark-active)) + (define-key menu-map [eval-sexp] + '(menu-item "Evaluate Last S-expression" eval-last-sexp + :help "Evaluate sexp before point; print value in minibuffer")) + (define-key menu-map [separator-format] '("--")) + (define-key menu-map [comment-region] + '(menu-item "Comment Out Region" comment-region + :help "Comment or uncomment each line in the region" + :enable mark-active)) + (define-key menu-map [indent-region] + '(menu-item "Indent Region" indent-region + :help "Indent each nonblank line in the region" + :enable mark-active)) + (define-key menu-map [indent-line] '("Indent Line" . lisp-indent-line)) + map) "Keymap for Emacs Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(if emacs-lisp-mode-map - () - (let ((map (make-sparse-keymap "Emacs-Lisp"))) - (setq emacs-lisp-mode-map (make-sparse-keymap)) - (set-keymap-parent emacs-lisp-mode-map lisp-mode-shared-map) - (define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol) - (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun) - (define-key emacs-lisp-mode-map "\e\C-q" 'indent-pp-sexp) - (define-key emacs-lisp-mode-map [menu-bar] (make-sparse-keymap)) - (define-key emacs-lisp-mode-map [menu-bar emacs-lisp] - (cons "Emacs-Lisp" map)) - (define-key map [edebug-defun] - '("Instrument Function for Debugging" . edebug-defun)) - (define-key map [byte-recompile] - '("Byte-recompile Directory..." . byte-recompile-directory)) - (define-key map [emacs-byte-compile-and-load] - '("Byte-compile And Load" . emacs-lisp-byte-compile-and-load)) - (define-key map [byte-compile] - '("Byte-compile This File" . emacs-lisp-byte-compile)) - (define-key map [separator-eval] '("--")) - (define-key map [eval-buffer] '("Evaluate Buffer" . eval-buffer)) - (define-key map [eval-region] '("Evaluate Region" . eval-region)) - (define-key map [eval-sexp] '("Evaluate Last S-expression" . eval-last-sexp)) - (define-key map [separator-format] '("--")) - (define-key map [comment-region] '("Comment Out Region" . comment-region)) - (define-key map [indent-region] '("Indent Region" . indent-region)) - (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) - (put 'eval-region 'menu-enable 'mark-active) - (put 'comment-region 'menu-enable 'mark-active) - (put 'indent-region 'menu-enable 'mark-active))) - (defun emacs-lisp-byte-compile () "Byte compile the file containing the current buffer." (interactive) @@ -364,10 +429,21 @@ if that value is non-nil." (put 'emacs-lisp-mode 'custom-mode-group 'lisp) (defvar lisp-mode-map - (let ((map (make-sparse-keymap))) + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap "Lisp"))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\e\C-x" 'lisp-eval-defun) (define-key map "\C-c\C-z" 'run-lisp) + (define-key map [menu-bar lisp] (cons "Lisp" menu-map)) + (define-key menu-map [run-lisp] + '(menu-item "Run inferior Lisp" run-lisp + :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'")) + (define-key menu-map [ev-def] + '(menu-item "Eval defun" lisp-eval-defun + :help "Send the current defun to the Lisp process made by M-x run-lisp")) + (define-key menu-map [ind-sexp] + '(menu-item "Indent sexp" indent-sexp + :help "Indent each line of the list starting just after point")) map) "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") @@ -416,12 +492,30 @@ if that value is non-nil." (error "Process lisp does not exist")) (defvar lisp-interaction-mode-map - (let ((map (make-sparse-keymap))) + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap "Lisp-Interaction"))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\e\C-x" 'eval-defun) (define-key map "\e\C-q" 'indent-pp-sexp) (define-key map "\e\t" 'lisp-complete-symbol) (define-key map "\n" 'eval-print-last-sexp) + (define-key map [menu-bar lisp-interaction] (cons "Lisp-Interaction" menu-map)) + (define-key menu-map [eval-defun] + '(menu-item "Evaluate Defun" eval-defun + :help "Evaluate the top-level form containing point, or after point")) + (define-key menu-map [eval-print-last-sexp] + '(menu-item "Evaluate and print" eval-print-last-sexp + :help "Evaluate sexp before point; print value into current buffer")) + (define-key menu-map [edebug-defun-lisp-interaction] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (define-key menu-map [indent-pp-sexp] + '(menu-item "Indent or Pretty-Print" indent-pp-sexp + :help "Indent each line of the list starting just after point, or prettyprint it")) + (define-key menu-map [lisp-complete-symbol] + '(menu-item "Complete Lisp Symbol" lisp-complete-symbol + :help "Perform completion on Lisp symbol preceding point")) map) "Keymap for Lisp Interaction mode. All commands in `lisp-mode-shared-map' are inherited by this map.") @@ -696,6 +790,8 @@ if it already has a value.\) With argument, insert value in current buffer after the defun. Return the result of evaluation." (interactive "P") + ;; FIXME: the print-length/level bindings should only be applied while + ;; printing, not while evaluating. (let ((debug-on-error eval-expression-debug-on-error) (print-length eval-expression-print-length) (print-level eval-expression-print-level)) @@ -766,22 +862,9 @@ which see." value))))) ;; May still be used by some external Lisp-mode variant. -(define-obsolete-function-alias 'lisp-comment-indent 'comment-indent-default) - -;; This function just forces a more costly detection of comments (using -;; parse-partial-sexp from beginning-of-defun). I.e. It avoids the problem of -;; taking a `;' inside a string started on another line for a comment starter. -;; Note: `newcomment' gets it right now since we set comment-use-global-state -;; so we could get rid of it. -stef -(defun lisp-mode-auto-fill () - (if (> (current-column) (current-fill-column)) - (if (save-excursion - (nth 4 (syntax-ppss (point)))) - (do-auto-fill) - (unless (and (boundp 'comment-auto-fill-only-comments) - comment-auto-fill-only-comments) - (let ((comment-start nil) (comment-start-skip nil)) - (do-auto-fill)))))) +(define-obsolete-function-alias 'lisp-comment-indent + 'comment-indent-default "22.1") +(define-obsolete-function-alias 'lisp-mode-auto-fill 'do-auto-fill "23.1") (defcustom lisp-indent-offset nil "If non-nil, indent second line of expressions that many more columns." diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 4fd6fe7a17f..3fe2fd1813c 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -176,9 +174,10 @@ normal recipe (see `beginning-of-defun'). Major modes can define this if defining `defun-prompt-regexp' is not sufficient to handle the mode's needs. -The function (of no args) should go to the line on which the current -defun starts, and return non-nil, or should return nil if it can't -find the beginning.") +The function takes the same argument as `beginning-of-defun' and should +behave similarly, returning non-nil if it found the beginning of a defun. +Ideally it should move to a point right before an open-paren which encloses +the body of the defun.") (defun beginning-of-defun (&optional arg) "Move backward to the beginning of a defun. @@ -219,12 +218,22 @@ is called as a function to find the defun's beginning." (unless arg (setq arg 1)) (cond (beginning-of-defun-function - (if (> arg 0) - (dotimes (i arg) - (funcall beginning-of-defun-function)) - ;; Better not call end-of-defun-function directly, in case - ;; it's not defined. - (end-of-defun (- arg)))) + (condition-case nil + (funcall beginning-of-defun-function arg) + ;; We used to define beginning-of-defun-function as taking no argument + ;; but that makes it impossible to implement correct forward motion: + ;; we used to use end-of-defun for that, but it's not supposed to do + ;; the same thing (it moves to the end of a defun not to the beginning + ;; of the next). + ;; In case the beginning-of-defun-function uses the old calling + ;; convention, fallback on the old implementation. + (wrong-number-of-arguments + (if (> arg 0) + (dotimes (i arg) + (funcall beginning-of-defun-function)) + ;; Better not call end-of-defun-function directly, in case + ;; it's not defined. + (end-of-defun (- arg)))))) ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) (and (< arg 0) (not (eobp)) (forward-char 1)) @@ -287,11 +296,11 @@ is called as a function to find the defun's beginning." (goto-char (if arg-+ve floor ceiling)) nil)))))))) -(defvar end-of-defun-function nil - "If non-nil, function for function `end-of-defun' to call. -This is used to find the end of the defun instead of using the normal -recipe (see `end-of-defun'). Major modes can define this if the -normal method is not appropriate.") +(defvar end-of-defun-function #'forward-sexp + "Function for `end-of-defun' to call. +This is used to find the end of the defun. +It is called with no argument, right after calling `beginning-of-defun-raw'. +So the function can assume that point is at the beginning of the defun body.") (defun buffer-end (arg) "Return the \"far end\" position of the buffer, in direction ARG. @@ -316,45 +325,38 @@ is called as a function to find the defun's end." (and transient-mark-mode mark-active) (push-mark)) (if (or (null arg) (= arg 0)) (setq arg 1)) - (if end-of-defun-function - (if (> arg 0) - (dotimes (i arg) - (funcall end-of-defun-function)) - ;; Better not call beginning-of-defun-function - ;; directly, in case it's not defined. - (beginning-of-defun (- arg))) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point))) - (while (progn - (if (and first - (progn - (end-of-line 1) - (beginning-of-defun-raw 1))) - nil - (or (bobp) (forward-char -1)) - (beginning-of-defun-raw -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (beginning-of-defun-raw 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (beginning-of-defun-raw 2) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg)))))) + (while (> arg 0) + (let ((pos (point))) + (end-of-line 1) + (beginning-of-defun-raw 1) + (while (unless (eobp) + (funcall end-of-defun-function) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)) + ;; If we started after the end of the previous function, then + ;; try again with the next one. + (when (<= (point) pos) + (or (bobp) (forward-char -1)) + (beginning-of-defun-raw -1) + 'try-again)))) + (setq arg (1- arg))) + (while (< arg 0) + (let ((pos (point))) + (while (unless (bobp) + (beginning-of-line 1) + (beginning-of-defun-raw 1) + (let ((beg (point))) + (funcall end-of-defun-function) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)) + ;; If we started from within the function just found, then + ;; try again with the previous one. + (when (>= (point) pos) + (goto-char beg) + 'try-again))))) + (setq arg (1+ arg)))) (defun mark-defun (&optional allow-extend) "Put mark at end of this defun, point at beginning. @@ -563,12 +565,47 @@ character." ;; "Unbalanced parentheses", but those may not be so ;; accurate/helpful, e.g. quotes may actually be ;; mismatched. - (error "Unmatched bracket or quote")) - (error (cond ((eq 'scan-error (car data)) - (goto-char (nth 2 data)) - (error "Unmatched bracket or quote")) - (t (signal (car data) (cdr data))))))) + (error "Unmatched bracket or quote")))) +(defun field-complete (table &optional predicate) + (let* ((pattern (field-string-no-properties)) + (completion (try-completion pattern table predicate))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= pattern completion)) + (delete-region (field-beginning) (field-end)) + (insert completion) + ;; Don't leave around a completions buffer that's out of date. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer))))) + (t + (let ((minibuf-is-in-use + (eq (minibuffer-window) (selected-window)))) + (unless minibuf-is-in-use + (message "Making completion list...")) + (let ((list (all-completions pattern table predicate))) + (setq list (sort list 'string<)) + (or (eq predicate 'fboundp) + (let (new) + (while list + (setq new (cons (if (fboundp (intern (car list))) + (list (car list) " <f>") + (car list)) + new)) + (setq list (cdr list))) + (setq list (nreverse new)))) + (if (> (length list) 1) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list pattern)) + ;; Don't leave around a completions buffer that's + ;; out of date. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer)))))) + (unless minibuf-is-in-use + (message "Making completion list...%s" "done"))))))) + (defun lisp-complete-symbol (&optional predicate) "Perform completion on Lisp symbol preceding point. Compare that symbol against the known Lisp symbols. @@ -628,7 +665,9 @@ considered." (completion (try-completion pattern obarray predicate))) (cond ((eq completion t)) ((null completion) - (message "Can't find completion for \"%s\"" pattern) + (if (window-minibuffer-p (selected-window)) + (minibuffer-message (format " [No completions of \"%s\"]" pattern)) + (message "Can't find completion for \"%s\"" pattern)) (ding)) ((not (string= pattern completion)) (delete-region beg end) diff --git a/lisp/emacs-lisp/lmenu.el b/lisp/emacs-lisp/lmenu.el index 389cb63f304..475d2094ca7 100644 --- a/lisp/emacs-lisp/lmenu.el +++ b/lisp/emacs-lisp/lmenu.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -18,9 +18,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -130,6 +128,8 @@ (setq menu-items (cdr menu-items))) menu)) +(declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) + ;; XEmacs compatibility function (defun popup-dialog-box (data) "Pop up a dialog box. @@ -439,5 +439,5 @@ BEFORE, if provided, is the name of a menu before which this menu should (provide 'lmenu) -;;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1 +;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1 ;;; lmenu.el ends here diff --git a/lisp/emacs-lisp/lselect.el b/lisp/emacs-lisp/lselect.el deleted file mode 100644 index 6b12e0e9967..00000000000 --- a/lisp/emacs-lisp/lselect.el +++ /dev/null @@ -1,242 +0,0 @@ -;;; lselect.el --- Lucid interface to X Selections - -;; Copyright (C) 1990, 1993, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: emulations - -;; This won't completely work until we support or emulate Lucid-style extents. -;; Based on Lucid's selection code. - -;; 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: - -;;; Code: - -;; The selection code requires us to use certain symbols whose names are -;; all upper-case; this may seem tasteless, but it makes there be a 1:1 -;; correspondence between these symbols and X Atoms (which are upcased.) - -;; This is Lucid/XEmacs stuff -(defvar mouse-highlight-priority) -(defvar x-lost-selection-functions) -(defvar zmacs-regions) - -(defalias 'x-get-cutbuffer 'x-get-cut-buffer) -(defalias 'x-store-cutbuffer 'x-set-cut-buffer) - -(or (facep 'primary-selection) - (make-face 'primary-selection)) - -(or (facep 'secondary-selection) - (make-face 'secondary-selection)) - -(defun x-get-secondary-selection () - "Return text selected from some X window." - (x-get-selection-internal 'SECONDARY 'STRING)) - -(defvar primary-selection-extent nil - "The extent of the primary selection; don't use this.") - -(defvar secondary-selection-extent nil - "The extent of the secondary selection; don't use this.") - - -(defun x-select-make-extent-for-selection (selection previous-extent face) - ;; Given a selection, this makes an extent in the buffer which holds that - ;; selection, for highlighting purposes. If the selection isn't associated - ;; with a buffer, this does nothing. - (let ((buffer nil) - (valid (and (extentp previous-extent) - (extent-buffer previous-extent) - (buffer-name (extent-buffer previous-extent)))) - start end) - (cond ((stringp selection) - ;; if we're selecting a string, lose the previous extent used - ;; to highlight the selection. - (setq valid nil)) - ((consp selection) - (setq start (min (car selection) (cdr selection)) - end (max (car selection) (cdr selection)) - valid (and valid - (eq (marker-buffer (car selection)) - (extent-buffer previous-extent))) - buffer (marker-buffer (car selection)))) - ((extentp selection) - (setq start (extent-start-position selection) - end (extent-end-position selection) - valid (and valid - (eq (extent-buffer selection) - (extent-buffer previous-extent))) - buffer (extent-buffer selection))) - ) - (if (and (not valid) - (extentp previous-extent) - (extent-buffer previous-extent) - (buffer-name (extent-buffer previous-extent))) - (delete-extent previous-extent)) - (if (not buffer) - ;; string case - nil - ;; normal case - (if valid - (set-extent-endpoints previous-extent start end) - (setq previous-extent (make-extent start end buffer)) - ;; use same priority as mouse-highlighting so that conflicts between - ;; the selection extent and a mouse-highlighted extent are resolved - ;; by the usual size-and-endpoint-comparison method. - (set-extent-priority previous-extent mouse-highlight-priority) - (set-extent-face previous-extent face))))) - - -(defun x-own-selection (selection &optional type) - "Make a primary X Selection of the given argument. -The argument may be a string, a cons of two markers, or an extent. -In the latter cases the selection is considered to be the text -between the markers, or the between extents endpoints." - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (cons ;; these need not be ordered. - (copy-marker (point-marker)) - (copy-marker (mark-marker)))))) - (or type (setq type 'PRIMARY)) - (x-set-selection selection type) - (cond ((eq type 'PRIMARY) - (setq primary-selection-extent - (x-select-make-extent-for-selection - selection primary-selection-extent 'primary-selection))) - ((eq type 'SECONDARY) - (setq secondary-selection-extent - (x-select-make-extent-for-selection - selection secondary-selection-extent 'secondary-selection)))) - selection) - - -(defun x-own-secondary-selection (selection &optional type) - "Make a secondary X Selection of the given argument. The argument may be a -string or a cons of two markers (in which case the selection is considered to -be the text between those markers.)" - (interactive (if (not current-prefix-arg) - (list (read-string "Store text for pasting: ")) - (list (cons ;; these need not be ordered. - (copy-marker (point-marker)) - (copy-marker (mark-marker)))))) - (x-own-selection selection 'SECONDARY)) - - -(defun x-own-clipboard (string) - "Paste the given string to the X Clipboard." - (x-own-selection string 'CLIPBOARD)) - - -(defun x-disown-selection (&optional secondary-p) - "Assuming we own the selection, disown it. With an argument, discard the -secondary selection instead of the primary selection." - (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))) - -(defun x-dehilight-selection (selection) - "for use as a value of `x-lost-selection-functions'." - (cond ((eq selection 'PRIMARY) - (if primary-selection-extent - (let ((inhibit-quit t)) - (delete-extent primary-selection-extent) - (setq primary-selection-extent nil))) - (if zmacs-regions (zmacs-deactivate-region))) - ((eq selection 'SECONDARY) - (if secondary-selection-extent - (let ((inhibit-quit t)) - (delete-extent secondary-selection-extent) - (setq secondary-selection-extent nil))))) - nil) - -(setq x-lost-selection-functions 'x-dehilight-selection) - -(defun x-notice-selection-requests (selection type successful) - "for possible use as the value of `x-sent-selection-functions'." - (if (not successful) - (message "Selection request failed to convert %s to %s" - selection type) - (message "Sent selection %s as %s" selection type))) - -(defun x-notice-selection-failures (selection type successful) - "for possible use as the value of `x-sent-selection-functions'." - (or successful - (message "Selection request failed to convert %s to %s" - selection type))) - -;(setq x-sent-selection-functions 'x-notice-selection-requests) -;(setq x-sent-selection-functions 'x-notice-selection-failures) - - -;; Random utility functions - -(defun x-kill-primary-selection () - "If there is a selection, delete the text it covers, and copy it to -both the kill ring and the Clipboard." - (interactive) - (or (x-selection-owner-p) (error "Emacs does not own the primary selection")) - (setq last-command nil) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (kill-region (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent))) - (x-disown-selection nil)) - -(defun x-delete-primary-selection () - "If there is a selection, delete the text it covers *without* copying it to -the kill ring or the Clipboard." - (interactive) - (or (x-selection-owner-p) (error "Emacs does not own the primary selection")) - (setq last-command nil) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (delete-region (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent))) - (x-disown-selection nil)) - -(defun x-copy-primary-selection () - "If there is a selection, copy it to both the kill ring and the Clipboard." - (interactive) - (setq last-command nil) - (or (x-selection-owner-p) (error "Emacs does not own the primary selection")) - (or primary-selection-extent - (error "the primary selection is not an extent?")) - (save-excursion - (set-buffer (extent-buffer primary-selection-extent)) - (copy-region-as-kill (extent-start-position primary-selection-extent) - (extent-end-position primary-selection-extent)))) - -(defun x-yank-clipboard-selection () - "If someone owns a Clipboard selection, insert it at point." - (interactive) - (setq last-command nil) - (let ((clip (x-get-clipboard))) - (or clip (error "there is no clipboard selection")) - (push-mark) - (insert clip))) - -(provide 'lselect) - -;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556 -;;; lselect.el ends here diff --git a/lisp/emacs-lisp/lucid.el b/lisp/emacs-lisp/lucid.el index 5c26a287b34..b46107e7fc3 100644 --- a/lisp/emacs-lisp/lucid.el +++ b/lisp/emacs-lisp/lucid.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -234,5 +232,5 @@ This is an XEmacs compatibility function." (provide 'lucid) -;;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e +;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e ;;; lucid.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index de5efe0845e..10e4ee7af91 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -18,9 +18,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; @@ -195,5 +193,5 @@ definitions to shadow the loaded ones for use in file byte-compilation." (provide 'macroexp) -;;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a +;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a ;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index fb9efe6da0f..ec173d1197b 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -36,6 +34,8 @@ ;;; Code: +(declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) + (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) "Ask a series of boolean questions. @@ -83,20 +83,14 @@ Returns the number of actions taken." ;; Non-nil means we should use mouse menus to ask. use-menus delayed-switch-frame - (next (if (or (and list (symbolp list)) - (subrp list) - (byte-code-function-p list) - (and (consp list) - (eq (car list) 'lambda))) - (function (lambda () - (setq elt (funcall list)))) - (function (lambda () - (if list - (progn - (setq elt (car list) - list (cdr list)) - t) - nil)))))) + ;; Rebind other-window-scroll-buffer so that subfunctions can set + ;; it temporarily, without risking affecting the caller. + (other-window-scroll-buffer other-window-scroll-buffer) + (next (if (functionp list) + (lambda () (setq elt (funcall list))) + (lambda () (when list + (setq elt (pop list)) + t))))) (if (and (listp last-nonmenu-event) use-dialog-box) ;; Make a list describing a dialog box. @@ -118,20 +112,30 @@ Returns the number of actions taken." use-menus t mouse-event last-nonmenu-event)) (setq user-keys (if action-alist - (concat (mapconcat (function - (lambda (elt) - (key-description - (char-to-string (car elt))))) + (concat (mapconcat (lambda (elt) + (key-description + (vector (car elt)))) action-alist ", ") " ") "") ;; Make a map that defines each user key as a vector containing ;; its definition. - map (cons 'keymap - (append (mapcar (lambda (elt) - (cons (car elt) (vector (nth 1 elt)))) - action-alist) - query-replace-map)))) + map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map query-replace-map) + (define-key map [?\C-\M-v] 'scroll-other-window) + (define-key map [M-next] 'scroll-other-window) + (define-key map [?\C-\M-\S-v] 'scroll-other-window-down) + (define-key map [M-prior] 'scroll-other-window-down) + ;; The above are rather inconvenient, so maybe we should + ;; provide the non-other keys for the other-scroll as well. + ;; (define-key map [?\C-v] 'scroll-other-window) + ;; (define-key map [next] 'scroll-other-window) + ;; (define-key map [?\M-v] 'scroll-other-window-down) + ;; (define-key map [prior] 'scroll-other-window-down) + (dolist (elt action-alist) + (define-key map (vector (car elt)) (vector (nth 1 elt)))) + map))) (unwind-protect (progn (if (stringp prompter) @@ -167,7 +171,7 @@ Returns the number of actions taken." (single-key-description char))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) - (setq next (function (lambda () nil)))) + (setq next (lambda () nil))) ((eq def 'act) ;; Act on the object. (funcall actor elt) @@ -179,7 +183,7 @@ Returns the number of actions taken." ;; Act on the object and then exit. (funcall actor elt) (setq actions (1+ actions) - next (function (lambda () nil)))) + next (lambda () nil))) ((eq def 'quit) (setq quit-flag t) (setq next `(lambda () @@ -222,13 +226,18 @@ C-g to quit (cancel the whole command); (format "or . (period) to %s \ the current %s and exit." action object)))) - (save-excursion - (set-buffer standard-output) + (with-current-buffer standard-output (help-mode))) (setq next `(lambda () (setq next ',next) ',elt))) + ((and (symbolp def) (commandp def)) + (call-interactively def) + ;; Regurgitated; try again. + (setq next `(lambda () + (setq next ',next) + ',elt))) ((vectorp def) ;; A user-defined key. (if (funcall (aref def 0) elt) ;Call its function. @@ -266,5 +275,5 @@ the current %s and exit." ;; Return the number of actions that were taken. actions)) -;;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3 +;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3 ;;; map-ynp.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index d5e86aae491..ad73134d254 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -96,14 +94,10 @@ can handle, whenever this is possible. Output stream is STREAM, or value of `standard-output' (which see)." (princ (pp-to-string object) (or stream standard-output))) -;;;###autoload -(defun pp-eval-expression (expression) - "Evaluate EXPRESSION and pretty-print its value. -Also add the value to the front of the list in the variable `values'." - (interactive - (list (read-from-minibuffer "Eval: " nil read-expression-map t - 'read-expression-history))) - (setq values (cons (eval expression) values)) +(defun pp-display-expression (expression out-buffer-name) + "Prettify and display EXPRESSION in an appropriate way, depending on length. +If a temporary buffer is needed for representation, it will be named +after OUT-BUFFER-NAME." (let* ((old-show-function temp-buffer-show-function) ;; Use this function to display the buffer. ;; This function either decides not to display it at all @@ -126,21 +120,38 @@ Also add the value to the front of the list in the variable `values'." (progn (select-window window) (run-hooks 'temp-buffer-show-hook)) - (select-window old-selected))) + (select-window old-selected) + (message "See buffer %s." out-buffer-name))) (message "%s" (buffer-substring (point-min) (point))) )))))) - (with-output-to-temp-buffer "*Pp Eval Output*" - (pp (car values)) + (with-output-to-temp-buffer out-buffer-name + (pp expression) (with-current-buffer standard-output (emacs-lisp-mode) + (setq buffer-read-only nil) (set (make-local-variable 'font-lock-verbose) nil))))) ;;;###autoload -(defun pp-eval-last-sexp (arg) - "Run `pp-eval-expression' on sexp before point (which see). -With argument, pretty-print output into current buffer. -Ignores leading comment characters." - (interactive "P") +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive + (list (read-from-minibuffer "Eval: " nil read-expression-map t + 'read-expression-history))) + (message "Evaluating...") + (setq values (cons (eval expression) values)) + (pp-display-expression (car values) "*Pp Eval Output*")) + +;;;###autoload +(defun pp-macroexpand-expression (expression) + "Macroexpand EXPRESSION and pretty-print its value." + (interactive + (list (read-from-minibuffer "Macroexpand: " nil read-expression-map t + 'read-expression-history))) + (pp-display-expression (macroexpand expression) "*Pp Macroexpand Output*")) + +(defun pp-last-sexp () + "Read sexp before point. Ignores leading comment characters." (let ((stab (syntax-table)) (pt (point)) start exp) (set-syntax-table emacs-lisp-mode-syntax-table) (save-excursion @@ -156,9 +167,27 @@ Ignores leading comment characters." (setq exp (read exp))) (setq exp (read (current-buffer))))) (set-syntax-table stab) - (if arg - (insert (pp-to-string (eval exp))) - (pp-eval-expression exp)))) + exp)) + +;;;###autoload +(defun pp-eval-last-sexp (arg) + "Run `pp-eval-expression' on sexp before point. +With argument, pretty-print output into current buffer. +Ignores leading comment characters." + (interactive "P") + (if arg + (insert (pp-to-string (eval (pp-last-sexp)))) + (pp-eval-expression (pp-last-sexp)))) + +;;;###autoload +(defun pp-macroexpand-last-sexp (arg) + "Run `pp-macroexpand-expression' on sexp before point. +With argument, pretty-print output into current buffer. +Ignores leading comment characters." + (interactive "P") + (if arg + (insert (pp-to-string (macroexpand (pp-last-sexp)))) + (pp-macroexpand-expression (pp-last-sexp)))) ;;; Test cases for quote ;; (pp-eval-expression ''(quote quote)) @@ -175,5 +204,5 @@ Ignores leading comment characters." (provide 'pp) ; so (require 'pp) works -;;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9 +;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9 ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 9205343c4da..a0b20375414 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -109,8 +107,8 @@ ;;; Code: ;; On XEmacs, load the overlay compatibility library -(if (not (fboundp 'make-overlay)) - (require 'overlay)) +(unless (fboundp 'make-overlay) + (require 'overlay)) ;; User customizable variables (defgroup re-builder nil @@ -119,17 +117,17 @@ :prefix "reb-") (defcustom reb-blink-delay 0.5 - "*Seconds to blink cursor for next/previous match in RE Builder." + "Seconds to blink cursor for next/previous match in RE Builder." :group 're-builder :type 'number) (defcustom reb-mode-hook nil - "*Hooks to run on entering RE Builder mode." + "Hooks to run on entering RE Builder mode." :group 're-builder :type 'hook) (defcustom reb-re-syntax 'read - "*Syntax for the REs in the RE Builder. + "Syntax for the REs in the RE Builder. Can either be `read', `string', `sregex', `lisp-re', `rx'." :group 're-builder :type '(choice (const :tag "Read syntax" read) @@ -139,7 +137,7 @@ Can either be `read', `string', `sregex', `lisp-re', `rx'." (const :tag "`rx' syntax" rx))) (defcustom reb-auto-match-limit 200 - "*Positive integer limiting the matches for RE Builder auto updates. + "Positive integer limiting the matches for RE Builder auto updates. Set it to nil if you don't want limits here." :group 're-builder :type '(restricted-sexp :match-alternatives @@ -232,7 +230,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") ;; Define the local "\C-c" keymap (defvar reb-mode-map - (let ((map (make-sparse-keymap))) + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'reb-toggle-case) (define-key map "\C-c\C-q" 'reb-quit) (define-key map "\C-c\C-w" 'reb-copy) @@ -242,6 +241,35 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key map "\C-c\C-e" 'reb-enter-subexp-mode) (define-key map "\C-c\C-b" 'reb-change-target-buffer) (define-key map "\C-c\C-u" 'reb-force-update) + (define-key map [menu-bar reb-mode] (cons "Re-Builder" menu-map)) + (define-key menu-map [rq] + '(menu-item "Quit" reb-quit + :help "Quit the RE Builder mode")) + (define-key menu-map [rt] + '(menu-item "Case sensitive" reb-toggle-case + :button (:toggle . case-fold-search) + :help "Toggle case sensitivity of searches for RE Builder target buffer.")) + (define-key menu-map [rb] + '(menu-item "Change target buffer..." reb-change-target-buffer + :help "Change the target buffer and display it in the target window")) + (define-key menu-map [rs] + '(menu-item "Change syntax..." reb-change-syntax + :help "Change the syntax used by the RE Builder")) + (define-key menu-map [re] + '(menu-item "Enter subexpression mode" reb-enter-subexp-mode + :help "Enter the subexpression mode in the RE Builder")) + (define-key menu-map [ru] + '(menu-item "Force update" reb-force-update + :help "Force an update in the RE Builder target window without a match limit")) + (define-key menu-map [rn] + '(menu-item "Go to next match" reb-next-match + :help "Go to next match in the RE Builder target window")) + (define-key menu-map [rp] + '(menu-item "Go to previous match" reb-prev-match + :help "Go to previous match in the RE Builder target window")) + (define-key menu-map [rc] + '(menu-item "Copy current RE" reb-copy + :help "Copy current RE into the kill ring for later insertion")) map) "Keymap used by the RE Builder.") @@ -292,12 +320,9 @@ Except for Lisp syntax this is the same as `reb-regexp'.") mode-line-buffer-identification '(25 . ("%b" reb-mode-string reb-valid-string))) (reb-update-modestring) - (make-local-variable 'after-change-functions) - (add-hook 'after-change-functions - 'reb-auto-update) + (add-hook 'after-change-functions 'reb-auto-update nil t) ;; At least make the overlays go away if the buffer is killed - (make-local-variable 'reb-kill-buffer) - (add-hook 'kill-buffer-hook 'reb-kill-buffer) + (add-hook 'kill-buffer-hook 'reb-kill-buffer nil t) (reb-auto-update nil nil nil)) (defun reb-color-display-p () @@ -326,6 +351,10 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (reb-lisp-mode)) (t (reb-mode)))) +(defun reb-mode-buffer-p () + "Return non-nil if the current buffer is a RE Builder buffer." + (memq major-mode '(reb-mode reb-lisp-mode))) + ;;; This is to help people find this in Apropos. ;;;###autoload (defalias 'regexp-builder 're-builder) @@ -336,10 +365,10 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (interactive) (if (and (string= (buffer-name) reb-buffer) - (memq major-mode '(reb-mode reb-lisp-mode))) + (reb-mode-buffer-p)) (message "Already in the RE Builder") - (if reb-target-buffer - (reb-delete-overlays)) + (when reb-target-buffer + (reb-delete-overlays)) (setq reb-target-buffer (current-buffer) reb-target-window (selected-window) reb-window-config (current-window-configuration)) @@ -385,7 +414,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (reb-assert-buffer-in-window) (with-selected-window reb-target-window (if (not (re-search-forward reb-regexp (point-max) t)) - (message "No more matches.") + (message "No more matches") (reb-show-subexp (or (and reb-subexp-mode reb-subexp-displayed) 0) t)))) @@ -403,7 +432,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (or (and reb-subexp-mode reb-subexp-displayed) 0) t) (goto-char p) - (message "No more matches."))))) + (message "No more matches"))))) (defun reb-toggle-case () "Toggle case sensitivity of searches for RE Builder target buffer." @@ -432,7 +461,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode.")) + (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. @@ -441,12 +470,12 @@ the match should already be marked by an overlay. On other displays jump to the beginning and the end of it. If the optional PAUSE is non-nil then pause at the end in any case." (with-selected-window reb-target-window - (if (not (reb-color-display-p)) - (progn (goto-char (match-beginning subexp)) - (sit-for reb-blink-delay))) + (unless (reb-color-display-p) + (goto-char (match-beginning subexp)) + (sit-for reb-blink-delay)) (goto-char (match-end subexp)) - (if (or (not (reb-color-display-p)) pause) - (sit-for reb-blink-delay)))) + (when (or (not (reb-color-display-p)) pause) + (sit-for reb-blink-delay)))) (defun reb-quit-subexp-mode () "Quit the subexpression mode in the RE Builder." @@ -494,10 +523,9 @@ optional fourth argument FORCE is non-nil." (new-valid (condition-case nil (progn - (if (or (reb-update-regexp) force) - (progn - (reb-assert-buffer-in-window) - (reb-do-update))) + (when (or (reb-update-regexp) force) + (reb-assert-buffer-in-window) + (reb-do-update)) "") (error " *invalid*")))) (setq reb-valid-string new-valid) @@ -506,16 +534,16 @@ optional fourth argument FORCE is non-nil." ;; Through the caching of the re a change invalidating the syntax ;; for symbolic expressions will not delete the overlays so we ;; catch it here - (if (and (reb-lisp-syntax-p) - (not (string= prev-valid new-valid)) - (string= prev-valid "")) - (reb-delete-overlays)))) + (when (and (reb-lisp-syntax-p) + (not (string= prev-valid new-valid)) + (string= prev-valid "")) + (reb-delete-overlays)))) (defun reb-delete-overlays () "Delete all RE Builder overlays in the `reb-target-buffer' buffer." - (if (buffer-live-p reb-target-buffer) + (when (buffer-live-p reb-target-buffer) (with-current-buffer reb-target-buffer - (mapcar 'delete-overlay reb-overlays) + (mapc 'delete-overlay reb-overlays) (setq reb-overlays nil)))) (defun reb-assert-buffer-in-window () @@ -548,8 +576,8 @@ optional fourth argument FORCE is non-nil." (defun reb-kill-buffer () "When the RE Builder buffer is killed make sure no overlays stay around." - (if (member major-mode '(reb-mode reb-lisp-mode)) - (reb-delete-overlays))) + (when (reb-mode-buffer-p) + (reb-delete-overlays))) ;; The next functions are the interface between the regexp and @@ -594,8 +622,8 @@ 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) - (if (fboundp 'lre-compile-string) - (lre-compile-string (eval (car (read-from-string re)))))) + (when (fboundp 'lre-compile-string) + (lre-compile-string (eval (car (read-from-string re)))))) ((eq reb-re-syntax 'sregex) (apply 'sregex (eval (car (read-from-string re))))) ((eq reb-re-syntax 'rx) @@ -613,8 +641,8 @@ Return t if the (cooked) expression changed." (not (string= oldre re)) (setq reb-regexp re) ;; Only update the source re for the lisp formats - (if (reb-lisp-syntax-p) - (setq reb-regexp-src re-src))))))) + (when (reb-lisp-syntax-p) + (setq reb-regexp-src re-src))))))) ;; And now the real core of the whole thing @@ -643,38 +671,38 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (re-search-forward re (point-max) t) (or (not reb-auto-match-limit) (< matches reb-auto-match-limit))) - (if (= 0 (length (match-string 0))) - (unless (eobp) - (forward-char 1))) + (when (and (= 0 (length (match-string 0))) + (not (eobp))) + (forward-char 1)) (let ((i 0) suffix max-suffix) (setq matches (1+ matches)) (while (<= i subexps) - (if (and (or (not subexp) (= subexp i)) - (match-beginning i)) - (let ((overlay (make-overlay (match-beginning i) - (match-end i))) - ;; When we have exceeded the number of provided faces, - ;; cycle thru them where `max-suffix' denotes the maximum - ;; suffix for `reb-match-*' that has been defined and - ;; `suffix' the suffix calculated for the current match. - (face - (cond - (max-suffix - (if (= suffix max-suffix) - (setq suffix 1) - (setq suffix (1+ suffix))) - (intern-soft (format "reb-match-%d" suffix))) - ((intern-soft (format "reb-match-%d" i))) - ((setq max-suffix (1- i)) - (setq suffix 1) - ;; `reb-match-1' must exist. - 'reb-match-1)))) - (unless firstmatch (setq firstmatch (match-data))) - (setq reb-overlays (cons overlay reb-overlays) - submatches (1+ submatches)) - (overlay-put overlay 'face face) - (overlay-put overlay 'priority i))) + (when (and (or (not subexp) (= subexp i)) + (match-beginning i)) + (let ((overlay (make-overlay (match-beginning i) + (match-end i))) + ;; When we have exceeded the number of provided faces, + ;; cycle thru them where `max-suffix' denotes the maximum + ;; suffix for `reb-match-*' that has been defined and + ;; `suffix' the suffix calculated for the current match. + (face + (cond + (max-suffix + (if (= suffix max-suffix) + (setq suffix 1) + (setq suffix (1+ suffix))) + (intern-soft (format "reb-match-%d" suffix))) + ((intern-soft (format "reb-match-%d" i))) + ((setq max-suffix (1- i)) + (setq suffix 1) + ;; `reb-match-1' must exist. + 'reb-match-1)))) + (unless firstmatch (setq firstmatch (match-data))) + (setq reb-overlays (cons overlay reb-overlays) + submatches (1+ submatches)) + (overlay-put overlay 'face face) + (overlay-put overlay 'priority i))) (setq i (1+ i)))))) (let ((count (if subexp submatches matches))) (message "%s %smatch%s%s" @@ -684,11 +712,24 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (if (and reb-auto-match-limit (= reb-auto-match-limit count)) " (limit reached)" ""))) - (if firstmatch - (progn (store-match-data firstmatch) - (reb-show-subexp (or subexp 0)))))) + (when firstmatch + (store-match-data firstmatch) + (reb-show-subexp (or subexp 0))))) + +;; The End +(defun re-builder-unload-function () + "Unload the RE Builder library." + (when (buffer-live-p (get-buffer reb-buffer)) + (with-current-buffer reb-buffer + (remove-hook 'after-change-functions 'reb-auto-update t) + (remove-hook 'kill-buffer-hook 'reb-kill-buffer t) + (when (reb-mode-buffer-p) + (reb-delete-overlays) + (funcall default-major-mode)))) + ;; continue standard unloading + nil) (provide 're-builder) -;;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7 +;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7 ;;; re-builder.el ends here diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 00f5bf5227a..309c8e7bb89 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -101,15 +99,15 @@ If PAREN is `words', then the resulting regexp is additionally surrounded by \\=\\< and \\>." (save-match-data ;; Recurse on the sorted list. - (let* ((max-lisp-eval-depth (* 1024 1024)) - (max-specpdl-size (* 1024 1024)) + (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 open))) + (re (regexp-opt-group sorted-strings (or open t) (not open)))) (if words (concat "\\<" re "\\>") re)))) ;;;###autoload @@ -226,7 +224,7 @@ This means the number of non-shy regexp grouping constructs ;; Otherwise, divide the list into those that start with a ;; particular letter and those that do not, and recurse on them. - (let* ((char (char-to-string (string-to-char (car strings)))) + (let* ((char (substring-no-properties (car strings) 0 1)) (half1 (all-completions char strings)) (half2 (nthcdr (length half1) strings))) (concat open-group @@ -263,13 +261,21 @@ This means the number of non-shy regexp grouping constructs (map-char-table (lambda (c v) (when v - (if (= (1- c) end) (setq end c) - (if (> end (+ start 2)) + (if (consp c) + (if (= (1- (car c)) end) (setq end (cdr c)) + (if (> end (+ start 2)) + (setq charset (format "%s%c-%c" charset start end)) + (while (>= end start) + (setq charset (format "%s%c" charset start)) + (incf start))) + (setq start (car c) end (cdr c))) + (if (= (1- c) end) (setq end c) + (if (> end (+ start 2)) (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) (incf start))) - (setq start c end c)))) + (setq start c end c))))) charmap) (when (>= end start) (if (> end (+ start 2)) diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 4d96bd9550b..5ea2c2a87b7 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -12,10 +12,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -23,9 +23,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -166,7 +164,7 @@ useful information: ;; lets find the special tags and remove them from the working ;; frame. note that only the last special tag is used. - (mapcar + (mapc (function (lambda (entry) (let ((pred (car entry)) @@ -256,5 +254,5 @@ useful information: (provide 'regi) -;;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747 +;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747 ;;; regi.el ends here diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index bcf29bd25bc..1bcfbf4a1d9 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -51,8 +49,8 @@ (defun ring-p (x) "Return t if X is a ring; nil otherwise." (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) + (consp (cdr x)) (integerp (cadr x)) + (vectorp (cddr x)))) ;;;###autoload (defun make-ring (size) @@ -60,11 +58,11 @@ (cons 0 (cons 0 (make-vector size nil)))) (defun ring-insert-at-beginning (ring item) - "Add to RING the item ITEM. Add it at the front, as the oldest item." - (let* ((vec (cdr (cdr ring))) + "Add to RING the item ITEM, at the front, as the oldest item." + (let* ((vec (cddr ring)) (veclen (length vec)) (hd (car ring)) - (ln (car (cdr ring)))) + (ln (cadr ring))) (setq ln (min veclen (1+ ln)) hd (ring-minus1 hd veclen)) (aset vec hd item) @@ -73,16 +71,16 @@ (defun ring-plus1 (index veclen) "Return INDEX+1, with wraparound." - (let ((new-index (+ index 1))) + (let ((new-index (1+ index))) (if (= new-index veclen) 0 new-index))) (defun ring-minus1 (index veclen) "Return INDEX-1, with wraparound." - (- (if (= 0 index) veclen index) 1)) + (- (if (zerop index) veclen index) 1)) (defun ring-length (ring) "Return the number of elements in the RING." - (car (cdr ring))) + (cadr ring)) (defun ring-index (index head ringlen veclen) "Convert nominal ring index INDEX to an internal index. @@ -95,26 +93,26 @@ VECLEN is the size of the vector in the ring." (defun ring-empty-p (ring) "Return t if RING is empty; nil otherwise." - (zerop (car (cdr ring)))) + (zerop (cadr ring))) (defun ring-size (ring) "Return the size of RING, the maximum number of elements it can contain." - (length (cdr (cdr ring)))) + (length (cddr ring))) (defun ring-copy (ring) "Return a copy of RING." - (let* ((vec (cdr (cdr ring))) - (hd (car ring)) - (ln (car (cdr ring)))) + (let ((vec (cddr ring)) + (hd (car ring)) + (ln (cadr ring))) (cons hd (cons ln (copy-sequence vec))))) (defun ring-insert (ring item) "Insert onto ring RING the item ITEM, as the newest (last) item. If the ring is full, dump the oldest item to make room." - (let* ((vec (cdr (cdr ring))) + (let* ((vec (cddr ring)) (veclen (length vec)) (hd (car ring)) - (ln (car (cdr ring)))) + (ln (cadr ring))) (prog1 (aset vec (mod (+ hd ln) veclen) item) (if (= ln veclen) @@ -128,13 +126,13 @@ numeric, remove the element indexed." (if (ring-empty-p ring) (error "Ring empty") (let* ((hd (car ring)) - (ln (car (cdr ring))) - (vec (cdr (cdr ring))) + (ln (cadr ring)) + (vec (cddr ring)) (veclen (length vec)) (tl (mod (1- (+ hd ln)) veclen)) oldelt) - (if (null index) - (setq index (1- ln))) + (when (null index) + (setq index (1- ln))) (setq index (ring-index index hd ln veclen)) (setq oldelt (aref vec index)) (while (/= index tl) @@ -152,7 +150,9 @@ INDEX need not be <= the ring length; the appropriate modulo operation will be performed." (if (ring-empty-p ring) (error "Accessing an empty ring") - (let* ((hd (car ring)) (ln (car (cdr ring))) (vec (cdr (cdr ring)))) + (let ((hd (car ring)) + (ln (cadr ring)) + (vec (cddr ring))) (aref vec (ring-index index hd ln (length vec)))))) (defun ring-elements (ring) @@ -164,9 +164,77 @@ will be performed." (dotimes (var (cadr ring) lst) (push (aref vect (mod (+ start var) size)) lst)))) +(defun ring-member (ring item) + "Return index of ITEM if on RING, else nil. +Comparison is done via `equal'. The index is 0-based." + (catch 'found + (dotimes (ind (ring-length ring) nil) + (when (equal item (ring-ref ring ind)) + (throw 'found ind))))) + +(defun ring-next (ring item) + "Return the next item in the RING, after ITEM. +Raise error if ITEM is not in the RING." + (let ((curr-index (ring-member ring item))) + (unless curr-index (error "Item is not in the ring: `%s'" item)) + (ring-ref ring (ring-plus1 curr-index (ring-length ring))))) + +(defun ring-previous (ring item) + "Return the previous item in the RING, before ITEM. +Raise error if ITEM is not in the RING." + (let ((curr-index (ring-member ring item))) + (unless curr-index (error "Item is not in the ring: `%s'" item)) + (ring-ref ring (ring-minus1 curr-index (ring-length ring))))) + +(defun ring-insert+extend (ring item &optional grow-p) + "Like `ring-insert', but if GROW-P is non-nil, then enlarge ring. +Insert onto ring RING the item ITEM, as the newest (last) item. +If the ring is full, behavior depends on GROW-P: + If GROW-P is non-nil, enlarge the ring to accommodate the new item. + If GROW-P is nil, dump the oldest item to make room for the new." + (let* ((vec (cddr ring)) + (veclen (length vec)) + (hd (car ring)) + (ringlen (ring-length ring))) + (prog1 + (cond ((and grow-p (= ringlen veclen)) ; Full ring. Enlarge it. + (setq veclen (1+ veclen)) + (setcdr ring (cons (setq ringlen (1+ ringlen)) + (setq vec (vconcat vec (vector item))))) + (setcar ring hd)) + (t (aset vec (mod (+ hd ringlen) veclen) item))) + (if (= ringlen veclen) + (setcar ring (ring-plus1 hd veclen)) + (setcar (cdr ring) (1+ ringlen)))))) + +(defun ring-remove+insert+extend (ring item &optional grow-p) + "`ring-remove' ITEM from RING, then `ring-insert+extend' it. +This ensures that there is only one ITEM on RING. + +If the RING is full, behavior depends on GROW-P: + If GROW-P is non-nil, enlarge the ring to accommodate the new ITEM. + If GROW-P is nil, dump the oldest item to make room for the new." + (let (ind) + (while (setq ind (ring-member ring item)) + (ring-remove ring ind))) + (ring-insert+extend ring item grow-p)) + +(defun ring-convert-sequence-to-ring (seq) + "Convert sequence SEQ to a ring. Return the ring. +If SEQ is already a ring, return it." + (if (ring-p seq) + seq + (let* ((size (length seq)) + (ring (make-ring size))) + (dotimes (count size) + (when (or (ring-empty-p ring) + (not (equal (ring-ref ring 0) (elt seq count)))) + (ring-insert-at-beginning ring (elt seq count)))) + ring))) + ;;; provide ourself: (provide 'ring) -;;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2 +;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2 ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 662f47a063c..297bb1a6460 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -120,7 +118,7 @@ (| . or) ; SRE (not-newline . ".") (nonl . not-newline) ; SRE - (anything . ".\\|\n") + (anything . "\\(?:.\\|\n\\)") (any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE (in . any) (char . any) ; sregex @@ -679,7 +677,7 @@ CHAR `not-newline', `nonl' matches any character except a newline. - . + `anything' matches any character @@ -946,14 +944,8 @@ enclosed in `(and ...)'. matches N to M occurrences. `(backref N)' - matches what was matched previously by submatch N. - -`(backref N)' matches what was matched previously by submatch N. -`(backref N)' - matches what was matched previously by submatch N. - `(eval FORM)' evaluate FORM and insert result. If result is a string, `regexp-quote' it. diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index f4a3cd6b931..1b3952a26a3 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -261,5 +259,5 @@ version unless you know what you are doing.\n") (provide 'shadow) -;;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 +;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 ;;; shadow.el ends here diff --git a/lisp/emacs-lisp/sregex.el b/lisp/emacs-lisp/sregex.el index 94711011317..43810353b7c 100644 --- a/lisp/emacs-lisp/sregex.el +++ b/lisp/emacs-lisp/sregex.el @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -20,9 +20,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -565,7 +563,7 @@ has one of the following forms: (let ((chars (make-bool-vector 256 nil))) ; Yeah, right! (dolist (arg args) (cond ((integerp arg) (aset chars arg t)) - ((stringp arg) (mapcar (lambda (c) (aset chars c t)) arg)) + ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg)) ((consp arg) (let ((start (car arg)) (end (cdr arg))) @@ -606,5 +604,5 @@ has one of the following forms: (provide 'sregex) -;;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492 +;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492 ;;; sregex.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index a7c844e3c80..be607c52c68 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 15ac08a490a..54589371197 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,15 +1,16 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 +;; Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: spreadsheet lisp utility -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -17,15 +18,24 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. (require 'testcover) (defvar ses-initial-global-parameters) (defvar ses-mode-map) +(declare-function ses-set-curcell "ses") +(declare-function ses-update-cells "ses") +(declare-function ses-load "ses") +(declare-function ses-vector-delete "ses") +(declare-function ses-create-header-string "ses") +(declare-function ses-read-cell "ses") +(declare-function ses-read-symbol "ses") +(declare-function ses-command-hook "ses") +(declare-function ses-jump "ses") + + ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. (let* ((pause nil) @@ -711,5 +721,5 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 +;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 ;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index eb4a3d67c72..49841a85ff0 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. (require 'testcover) @@ -111,6 +109,7 @@ ) "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") +(declare-function unsafep-function "unsafep" (fun)) ;;;######################################################################### (defun testcover-unsafep () @@ -138,5 +137,5 @@ (testcover-end "unsafep.el") (message "Done")) -;;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 +;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 ;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index de230ef5915..97a37c00e88 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -536,5 +534,5 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) -;;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 +;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index a6d6e4e9a37..9f5f72d81fe 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -18,9 +18,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -35,29 +33,45 @@ ;; triggered-p is nil if the timer is active (waiting to be triggered), ;; t if it is inactive ("already triggered", in theory) -(defun timer-create () - "Create a timer object which can be passed to `timer-activate'." - (let ((timer (make-vector 8 nil))) - (aset timer 0 t) - timer)) +(eval-when-compile (require 'cl)) + +(defstruct (timer + (:constructor nil) + (:copier nil) + (:constructor timer-create ()) + (:type vector) + (:conc-name timer--)) + (triggered t) + high-seconds low-seconds usecs repeat-delay function args idle-delay) (defun timerp (object) "Return t if OBJECT is a timer." (and (vectorp object) (= (length object) 8))) +;; Pseudo field `time'. +(defun timer--time (timer) + (list (timer--high-seconds timer) + (timer--low-seconds timer) + (timer--usecs timer))) + +(defsetf timer--time + (lambda (timer time) + (or (timerp timer) (error "Invalid timer")) + (setf (timer--high-seconds timer) (pop time)) + (setf (timer--low-seconds timer) + (if (consp time) (car time) time)) + (setf (timer--usecs timer) (or (and (consp time) (consp (cdr time)) + (cadr time)) + 0)))) + + (defun timer-set-time (timer time &optional delta) "Set the trigger time of TIMER to TIME. TIME must be in the internal format returned by, e.g., `current-time'. If optional third argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time))) - (nth 2 time)) - 0)) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) + (setf (timer--time timer) time) + (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) (defun timer-set-idle-time (timer secs &optional repeat) @@ -66,19 +80,11 @@ SECS may be an integer, floating point number, or the internal time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. If optional third argument REPEAT is non-nil, make the timer fire each time Emacs is idle for that many seconds." - (or (timerp timer) - (error "Invalid timer")) (if (consp secs) - (progn (aset timer 1 (car secs)) - (aset timer 2 (if (consp (cdr secs)) (car (cdr secs)) (cdr secs))) - (aset timer 3 (or (and (consp (cdr secs)) (consp (cdr (cdr secs))) - (nth 2 secs)) - 0))) - (aset timer 1 0) - (aset timer 2 0) - (aset timer 3 0) + (setf (timer--time timer) secs) + (setf (timer--time timer) '(0 0 0)) (timer-inc-time timer secs)) - (aset timer 4 repeat) + (setf (timer--repeat-delay timer) repeat) timer) (defun timer-next-integral-multiple-of-time (time secs) @@ -115,6 +121,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (defun timer-relative-time (time secs &optional usecs) "Advance TIME by SECS seconds and optionally USECS microseconds. SECS may be either an integer or a floating point number." + ;; FIXME: we should just use (time-add time (list 0 secs usecs)) (let ((high (car time)) (low (if (consp (cdr time)) (nth 1 time) (cdr time))) (micro (if (numberp (car-safe (cdr-safe (cdr time)))) @@ -136,16 +143,22 @@ SECS may be either an integer or a floating point number." (list high low (and (/= micro 0) micro)))) +(defun timer--time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + ;; FIXME just use time-less-p. + (destructuring-bind (high1 low1 micro1) (timer--time t1) + (destructuring-bind (high2 low2 micro2) (timer--time t2) + (or (< high1 high2) + (and (= high1 high2) + (or (< low1 low2) + (and (= low1 low2) + (< micro1 micro2)))))))) + (defun timer-inc-time (timer secs &optional usecs) "Increment the time set in TIMER by SECS seconds and USECS microseconds. SECS may be a fraction. If USECS is omitted, that means it is zero." - (let ((time (timer-relative-time - (list (aref timer 1) (aref timer 2) (aref timer 3)) - secs - usecs))) - (aset timer 1 (nth 0 time)) - (aset timer 2 (nth 1 time)) - (aset timer 3 (or (nth 2 time) 0)))) + (setf (timer--time timer) + (timer-relative-time (timer--time timer) secs usecs))) (defun timer-set-time-with-usecs (timer time usecs &optional delta) "Set the trigger time of TIMER to TIME plus USECS. @@ -153,12 +166,9 @@ TIME must be in the internal format returned by, e.g., `current-time'. The microsecond count from TIME is ignored, and USECS is used instead. If optional fourth argument DELTA is a positive number, make the timer fire repeatedly that many seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (nth 0 time)) - (aset timer 2 (nth 1 time)) - (aset timer 3 usecs) - (aset timer 4 (and (numberp delta) (> delta 0) delta)) + (setf (timer--time timer) time) + (setf (timer--usecs timer) usecs) + (setf (timer--repeat-delay timer) (and (numberp delta) (> delta 0) delta)) timer) (make-obsolete 'timer-set-time-with-usecs "use `timer-set-time' and `timer-inc-time' instead." @@ -168,34 +178,20 @@ fire repeatedly that many seconds apart." "Make TIMER call FUNCTION with optional ARGS when triggering." (or (timerp timer) (error "Invalid timer")) - (aset timer 5 function) - (aset timer 6 args) + (setf (timer--function timer) function) + (setf (timer--args timer) args) timer) -(defun timer-activate (timer &optional triggered-p reuse-cell) - "Put TIMER on the list of active timers. - -If TRIGGERED-P is t, that means to make the timer inactive -\(put it on the list, but mark it as already triggered). -To remove from the list, use `cancel-timer'. - -REUSE-CELL, if non-nil, is a cons cell to reuse instead -of allocating a new one." +(defun timer--activate (timer &optional triggered-p reuse-cell idle) (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-list) + (integerp (timer--high-seconds timer)) + (integerp (timer--low-seconds timer)) + (integerp (timer--usecs timer)) + (timer--function timer)) + (let ((timers (if idle timer-idle-list timer-list)) last) ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) + (while (and timers (timer--time-less-p (car timers) timer)) (setq last timers timers (cdr timers))) (if reuse-cell @@ -206,12 +202,25 @@ of allocating a new one." ;; Insert new timer after last which possibly means in front of queue. (if last (setcdr last reuse-cell) - (setq timer-list reuse-cell)) - (aset timer 0 triggered-p) - (aset timer 7 nil) + (if idle + (setq timer-idle-list reuse-cell) + (setq timer-list reuse-cell))) + (setf (timer--triggered timer) triggered-p) + (setf (timer--idle-delay timer) idle) nil) (error "Invalid or uninitialized timer"))) +(defun timer-activate (timer &optional triggered-p reuse-cell idle) + "Put TIMER on the list of active timers. + +If TRIGGERED-P is t, that means to make the timer inactive +\(put it on the list, but mark it as already triggered). +To remove from the list, use `cancel-timer'. + +REUSE-CELL, if non-nil, is a cons cell to reuse instead +of allocating a new one." + (timer--activate timer triggered-p reuse-cell nil)) + (defun timer-activate-when-idle (timer &optional dont-wait reuse-cell) "Arrange to activate TIMER whenever Emacs is next idle. If optional argument DONT-WAIT is non-nil, then enable the @@ -220,40 +229,10 @@ is already idle. REUSE-CELL, if non-nil, is a cons cell to reuse instead of allocating a new one." - (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-idle-list) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) - (setq last timers - timers (cdr timers))) - (if reuse-cell - (progn - (setcar reuse-cell timer) - (setcdr reuse-cell timers)) - (setq reuse-cell (cons timer timers))) - ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last reuse-cell) - (setq timer-idle-list reuse-cell)) - (aset timer 0 (not dont-wait)) - (aset timer 7 t) - nil) - (error "Invalid or uninitialized timer"))) + (timer--activate timer (not dont-wait) reuse-cell 'idle)) -;;;###autoload (defalias 'disable-timeout 'cancel-timer) -;;;###autoload + (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (or (timerp timer) @@ -274,22 +253,17 @@ that was removed from the timer list." (setq timer-idle-list (delq timer timer-idle-list))) (or cell1 cell2))) -;;;###autoload (defun cancel-function-timers (function) "Cancel all timers which would run FUNCTION. This affects ordinary timers such as are scheduled by `run-at-time', and idle timers such as are scheduled by `run-with-idle-timer'." (interactive "aCancel timers of function: ") - (let ((tail timer-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-list (delq (car tail) timer-list))) - (setq tail (cdr tail)))) - (let ((tail timer-idle-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-idle-list (delq (car tail) timer-idle-list))) - (setq tail (cdr tail))))) + (dolist (timer timer-list) + (if (eq (timer--function timer) function) + (setq timer-list (delq timer timer-list)))) + (dolist (timer timer-idle-list) + (if (eq (timer--function timer) function) + (setq timer-idle-list (delq timer timer-idle-list))))) ;; Record the last few events, for debugging. (defvar timer-event-last nil @@ -310,8 +284,9 @@ how many will really happen.") "Calculate number of seconds from when TIMER will run, until TIME. TIMER is a timer, and stands for the time when its next repeat is scheduled. TIME is a time-list." - (let ((high (- (car time) (aref timer 1))) - (low (- (nth 1 time) (aref timer 2)))) + ;; FIXME: (time-to-seconds (time-subtract (timer--time timer) time)) + (let ((high (- (car time) (timer--high-seconds timer))) + (low (- (nth 1 time) (timer--low-seconds timer)))) (+ low (* high 65536)))) (defun timer-event-handler (timer) @@ -326,29 +301,30 @@ This function is called, by name, directly by the C code." ;; Delete from queue. Record the cons cell that was used. (setq cell (cancel-timer-internal timer)) ;; Re-schedule if requested. - (if (aref timer 4) - (if (aref timer 7) + (if (timer--repeat-delay timer) + (if (timer--idle-delay timer) (timer-activate-when-idle timer nil cell) - (timer-inc-time timer (aref timer 4) 0) + (timer-inc-time timer (timer--repeat-delay timer) 0) ;; If real time has jumped forward, ;; perhaps because Emacs was suspended for a long time, ;; limit how many times things get repeated. (if (and (numberp timer-max-repeats) (< 0 (timer-until timer (current-time)))) (let ((repeats (/ (timer-until timer (current-time)) - (aref timer 4)))) + (timer--repeat-delay timer)))) (if (> repeats timer-max-repeats) - (timer-inc-time timer (* (aref timer 4) repeats))))) + (timer-inc-time timer (* (timer--repeat-delay timer) + repeats))))) (timer-activate timer t cell) (setq retrigger t))) ;; Run handler. ;; We do this after rescheduling so that the handler function ;; can cancel its own timer successfully with cancel-timer. (condition-case nil - (apply (aref timer 5) (aref timer 6)) + (apply (timer--function timer) (timer--args timer)) (error nil)) (if retrigger - (aset timer 0 nil))) + (setf (timer--triggered timer) nil))) (error "Bogus timer event")))) ;; This function is incompatible with the one in levents.el. @@ -356,7 +332,9 @@ This function is called, by name, directly by the C code." "Non-nil if EVENT is a timeout event." (and (listp event) (eq (car event) 'timer-event))) -;;;###autoload + +(declare-function diary-entry-time "diary-lib" (s)) + (defun run-at-time (time repeat function &rest args) "Perform an action at time TIME. Repeat the action every REPEAT seconds, if REPEAT is non-nil. @@ -418,7 +396,6 @@ This function returns a timer object which you can use in `cancel-timer'." (timer-activate timer) timer)) -;;;###autoload (defun run-with-timer (secs repeat function &rest args) "Perform an action after a delay of SECS seconds. Repeat the action every REPEAT seconds, if REPEAT is non-nil. @@ -429,14 +406,12 @@ This function returns a timer object which you can use in `cancel-timer'." (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") (apply 'run-at-time secs repeat function args)) -;;;###autoload (defun add-timeout (secs function object &optional repeat) "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. If REPEAT is non-nil, repeat the timer every REPEAT seconds. This function is for compatibility; see also `run-with-timer'." (run-with-timer secs repeat function object)) -;;;###autoload (defun run-with-idle-timer (secs repeat function &rest args) "Perform an action the next time Emacs is idle for SECS seconds. The action is to call FUNCTION with arguments ARGS. @@ -463,12 +438,11 @@ 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)) -;;;###autoload (put 'with-timeout 'lisp-indent-function 1) +(put 'with-timeout 'lisp-indent-function 1) (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") -;;;###autoload (defmacro with-timeout (list &rest body) "Run BODY, but if it doesn't finish in SECONDS seconds, give up. If we give up, we run the TIMEOUT-FORMS and return the value of the last one. @@ -504,11 +478,7 @@ The value is a list that the debugger can pass to `with-timeout-unsuspend' when it exits, to make these timers start counting again." (mapcar (lambda (timer) (cancel-timer timer) - (list timer - (time-subtract - ;; The time that this timer will go off. - (list (aref timer 1) (aref timer 2) (aref timer 3)) - (current-time)))) + (list timer (time-subtract (timer--time timer) (current-time)))) with-timeout-timers)) (defun with-timeout-unsuspend (timer-spec-list) @@ -569,5 +539,5 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (provide 'timer) -;;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 +;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 ;;; timer.el ends here diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index 034d3cd307c..a7bfd3ac667 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -168,5 +166,5 @@ This produces more reliable results with some processes." (provide 'tq) -;;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 +;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 ;;; tq.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 4edb496db41..f474e8c72d5 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -21,9 +21,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;; LCD Archive Entry: ;; trace|Hans Chalupsky|hans@cs.buffalo.edu| @@ -187,15 +185,16 @@ (if (> level 1) " " "") level function - (mapconcat (lambda (binding) - (concat - (symbol-name (ad-arg-binding-field binding 'name)) - "=" - ;; do this so we'll see strings: - (prin1-to-string - (ad-arg-binding-field binding 'value)))) - argument-bindings - " "))) + (let ((print-circle t)) + (mapconcat (lambda (binding) + (concat + (symbol-name (ad-arg-binding-field binding 'name)) + "=" + ;; do this so we'll see strings: + (prin1-to-string + (ad-arg-binding-field binding 'value)))) + argument-bindings + " ")))) (defun trace-exit-message (function level value) ;; Generates a string that describes that FUNCTION has been exited at @@ -206,7 +205,7 @@ level function ;; do this so we'll see strings: - (prin1-to-string value))) + (let ((print-circle t)) (prin1-to-string value)))) (defun trace-make-advice (function buffer background) ;; Builds the piece of advice to be added to FUNCTION's advice info @@ -220,7 +219,8 @@ (trace-buffer (get-buffer-create ,buffer))) (unless inhibit-trace (with-current-buffer trace-buffer - ,(unless background '(pop-to-buffer trace-buffer)) + (set (make-local-variable 'window-point-insertion-type) t) + ,(unless background '(display-buffer trace-buffer)) (goto-char (point-max)) ;; Insert a separator from previous trace output: (if (= trace-level 1) (insert trace-separator)) @@ -230,7 +230,7 @@ ad-do-it (unless inhibit-trace (with-current-buffer trace-buffer - ,(unless background '(pop-to-buffer trace-buffer)) + ,(unless background '(display-buffer trace-buffer)) (goto-char (point-max)) (insert (trace-exit-message diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 8684adf7182..e61de23c341 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -8,10 +8,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -19,9 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 0bdcbf1a162..a6c77d4c5a0 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -7,10 +7,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; 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 @@ -18,9 +18,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -325,5 +323,5 @@ this is equivalent to `display-warning', using (provide 'warnings) -;;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496 +;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496 ;;; warnings.el ends here |