diff options
Diffstat (limited to 'lisp/emacs-lisp')
51 files changed, 1748 insertions, 1570 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 9267bc8ac91..578e0877d30 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -7,6 +7,7 @@ ;; Maintainer: FSF ;; Created: 12 Dec 1992 ;; Keywords: extensions, lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 5aea033fc78..248a2cf1312 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -6,6 +6,7 @@ ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: Kim F. Storm <storm@cua.dk> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -506,6 +507,7 @@ Changes to files in this list are not listed.") "ymakefile" "permute-index" "index.perm" "ibmrs6000.inp" + "b2m.c" "emacs.ico" "emacs21.ico" "LPF" "LEDIT" "OTHER.EMACSES" @@ -1026,5 +1028,4 @@ the Emacs source tree, from which to build the file." (provide 'authors) -;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1 ;;; authors.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 6951e90c8b4..532d68245d8 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -6,6 +6,7 @@ ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint +;; Package: emacs ;; This file is part of GNU Emacs. @@ -777,16 +778,17 @@ Calls `update-directory-autoloads' on the command line arguments." (with-temp-buffer (insert-file-contents mfile) (when (re-search-forward "^shortlisp= " nil t) - (setq lim (line-end-position)) - (while (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>" - lim t) + (while (and (not lim) + (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>" + nil t)) (push (expand-file-name (match-string 1) ldir) - autoload-excludes)))))))) + autoload-excludes) + (skip-chars-forward " \t") + (if (eolp) (setq lim t))))))))) (let ((args command-line-args-left)) (setq command-line-args-left nil) (apply 'update-directory-autoloads args))) (provide 'autoload) -;; arch-tag: 00244766-98f4-4767-bf42-8a22103441c6 ;;; autoload.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 998cee15342..96e2fb41e89 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -6,6 +6,7 @@ ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF ;; Keywords: extensions, internal +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index e461010a6ce..0b4043b1f2a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -7,6 +7,7 @@ ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -381,9 +382,11 @@ form)) ((or (byte-code-function-p fn) (eq 'lambda (car-safe fn))) - (byte-optimize-form-code-walker - (byte-compile-unfold-lambda form) - for-effect)) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion + form + (byte-optimize-form-code-walker newform 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 diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dbbf057ae22..0388435dbc2 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -7,6 +7,7 @@ ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -65,7 +66,6 @@ The return value of this function is not used." ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. (fset 'inline 'progn) -(put 'inline 'lisp-indent-function 0) ;;; Interface to inline functions. @@ -108,10 +108,11 @@ The return value of this function is not used." (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) -(defun set-advertised-calling-convention (function signature) +(defun set-advertised-calling-convention (function signature when) "Set the advertised SIGNATURE of FUNCTION. This will allow the byte-compiler to warn the programmer when she uses -an obsolete calling convention." +an obsolete calling convention. WHEN specifies since when the calling +convention was modified." (puthash (indirect-function function) signature advertised-signature-table)) @@ -132,7 +133,7 @@ was first made obsolete, for example a date or a release number." obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. - 'make-obsolete '(obsolete-name current-name when)) + 'make-obsolete '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-function-alias (obsolete-name current-name &optional when docstring) @@ -153,7 +154,7 @@ See the docstrings of `defalias' and `make-obsolete' for more details." (set-advertised-calling-convention ;; New code should always provide the `when' argument. 'define-obsolete-function-alias - '(obsolete-name current-name when &optional docstring)) + '(obsolete-name current-name when &optional docstring) "23.1") (defun make-obsolete-variable (obsolete-name current-name &optional when) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. @@ -175,7 +176,7 @@ was first made obsolete, for example a date or a release number." obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. - 'make-obsolete-variable '(obsolete-name current-name when)) + 'make-obsolete-variable '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-variable-alias (obsolete-name current-name &optional when docstring) @@ -210,7 +211,7 @@ CURRENT-NAME, if it does not already have them: (set-advertised-calling-convention ;; New code should always provide the `when' argument. 'define-obsolete-variable-alias - '(obsolete-name current-name when &optional docstring)) + '(obsolete-name current-name when &optional docstring) "23.1") ;; FIXME This is only defined in this file because the variable- and ;; function- versions are too. Unlike those two, this one is not used diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 217afea9f8a..b3ac7b83d79 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,12 +1,14 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code ;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Maintainer: FSF ;; Keywords: lisp +;; Package: emacs ;; This file is part of GNU Emacs. @@ -263,7 +265,7 @@ If it is 'byte, then only byte-level optimizations will be logged." (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious) + make-local mapcar constants suspicious lexical) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -1341,7 +1343,7 @@ extra args." (not (and (eq (get func 'byte-compile) 'cl-byte-compile-compiler-macro) (string-match "\\`c[ad]+r\\'" (symbol-name func))))) - (byte-compile-warn "Function `%s' from cl package called at runtime" + (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1547,6 +1549,9 @@ that already has a `.elc' file." (if (and (string-match emacs-lisp-file-regexp bytecomp-source) (file-readable-p bytecomp-source) (not (auto-save-file-name-p bytecomp-source)) + (not (string-equal dir-locals-file + (file-name-nondirectory + bytecomp-source))) (setq bytecomp-dest (byte-compile-dest-file bytecomp-source)) (if (file-exists-p bytecomp-dest) @@ -1693,17 +1698,28 @@ The value is non-nil if there were no errors, nil if errors." (insert "\n") ; aaah, unix. (if (file-writable-p target-file) ;; We must disable any code conversion here. - (let ((coding-system-for-write 'no-conversion)) + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile (make-temp-name target-file)) + (kill-emacs-hook + (cons (lambda () (ignore-errors (delete-file tempfile))) + kill-emacs-hook))) (if (memq system-type '(ms-dos 'windows-nt)) (setq buffer-file-type t)) - (when (file-exists-p target-file) - ;; Remove the target before writing it, so that any - ;; hard-links continue to point to the old file (this makes - ;; it possible for installed files to share disk space with - ;; the build tree, without causing problems when emacs-lisp - ;; files in the build tree are recompiled). - (delete-file target-file)) - (write-region (point-min) (point-max) target-file)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (rename-file tempfile target-file t) + (message "Wrote %s" target-file)) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" @@ -1784,14 +1800,7 @@ With argument ARG, insert value in current buffer after the form." (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) - (setq case-fold-search nil) - ;; This is a kludge. Some operating systems (OS/2, DOS) need to - ;; write files containing binary information specially. - ;; Under most circumstances, such files will be in binary - ;; overwrite mode, so those OS's use that flag to guess how - ;; they should write their data. Advise them that .elc files - ;; need to be written carefully. - (setq overwrite-mode 'overwrite-mode-binary)) + (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer bytecomp-inbuffer (and bytecomp-filename @@ -2140,6 +2149,11 @@ list that represents a doc string reference. ;; Since there is no doc string, we can compile this as a normal form, ;; and not do a file-boundary. (byte-compile-keep-pending form) + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (push (nth 1 form) byte-compile-bound-variables) (if (eq (car form) 'defconst) (push (nth 1 form) byte-compile-const-variables)) @@ -3791,6 +3805,11 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) @@ -4239,6 +4258,8 @@ and corresponding effects." (defvar byte-code-meter) (defun byte-compile-report-ops () + (or (boundp 'byte-metering-on) + (error "You must build Emacs with -DBYTE_CODE_METER to use this")) (with-output-to-temp-buffer "*Meter*" (set-buffer "*Meter*") (let ((i 0) n op off) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index d2abdcffe0d..88da7aab3be 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -62,11 +62,7 @@ (require 'eieio) ;;; Code: -(defvar chart-map nil "Keymap used in chart mode.") -(if chart-map - () - (setq chart-map (make-sparse-keymap)) - ) +(defvar chart-map (make-sparse-keymap) "Keymap used in chart mode.") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e7455b3fbb7..9acad6e67cb 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,7 +1,7 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -1207,9 +1207,6 @@ generating a buffered list of errors." map) "Keymap used to override evaluation key-bindings for documentation checking.") -(define-obsolete-variable-alias 'checkdoc-minor-keymap - 'checkdoc-minor-mode-map "21.1") - ;; Add in a menubar with easy-menu (easy-menu-define diff --git a/lisp/emacs-lisp/cl-compat.el b/lisp/emacs-lisp/cl-compat.el deleted file mode 100644 index 68d7c0ae3ba..00000000000 --- a/lisp/emacs-lisp/cl-compat.el +++ /dev/null @@ -1,199 +0,0 @@ -;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) - -;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 -;; Keywords: extensions - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; 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 emulations of internal routines of the older -;; CL package which users may have called directly from their code. -;; Use (require 'cl-compat) to get these routines. - -;; See cl.el for Change Log. - - -;;; Code: - -;; 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. - -(defmacro defkeyword (x &optional doc) - (list* 'defconst x (list 'quote x) (and doc (list doc)))) - -(defun keyword-of (sym) - (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) - - -;;; Multiple values. Note that the new package uses a different -;;; convention for multiple values. The following definitions -;;; emulate the old convention; all function names have been changed -;;; by capitalizing the first letter: Values, Multiple-value-*, -;;; to avoid conflict with the new-style definitions in cl-macs. - -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - -(defvar *mvalues-values* nil) - -(defun Values (&rest val-forms) - (setq *mvalues-values* val-forms) - (car val-forms)) - -(defun Values-list (val-forms) - (apply 'values val-forms)) - -(defmacro Multiple-value-list (form) - (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) - '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) - (list *mvalues-temp*)))) - -(defmacro Multiple-value-call (function &rest args) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) - - -;;; Routines for parsing keyword arguments. - -(defun build-klist (arglist keys &optional allow-others) - (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) - (or allow-others - (let ((bad (set-difference (mapcar 'car res) keys))) - (if bad (error "Bad keywords: %s not in %s" bad keys)))) - res)) - -(defun extract-from-klist (klist key &optional def) - (let ((res (assq key klist))) (if res (cdr res) def))) - -(defun keyword-argument-supplied-p (klist key) - (assq key klist)) - -(defun elt-satisfies-test-p (item elt klist) - (let ((test-not (cdr (assq ':test-not klist))) - (test (cdr (assq ':test klist))) - (key (cdr (assq ':key klist)))) - (if key (setq elt (funcall key elt))) - (if test-not (not (funcall test-not item elt)) - (funcall (or test 'eql) item elt)))) - - -;;; Rounding functions with old-style multiple value returns. - -(defun cl-floor (a &optional b) (Values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) -(defun cl-round (a &optional b) (Values-list (round* a b))) -(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) - -(defun safe-idiv (a b) - (let* ((q (/ (abs a) (abs b))) - (s (* (signum a) (signum b)))) - (Values q (- a (* s q b)) s))) - - -;; Internal routines. - -(defun pair-with-newsyms (oldforms) - (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms))) - (Values (mapcar* 'list newsyms oldforms) newsyms))) - -(defun zip-lists (evens odds) - (mapcan 'list evens odds)) - -(defun unzip-lists (list) - (let ((e nil) (o nil)) - (while list - (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) - (Values (nreverse e) (nreverse o)))) - -(defun reassemble-argslists (list) - (let ((n (apply 'min (mapcar 'length list))) (res nil)) - (while (>= (setq n (1- n)) 0) - (setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res))) - res)) - -(defun duplicate-symbols-p (list) - (let ((res nil)) - (while list - (if (memq (car list) (cdr list)) (setq res (cons (car list) res))) - (setq list (cdr list))) - res)) - - -;;; Setf internals. - -(defun setnth (n list x) - (setcar (nthcdr n list) x)) - -(defun setnthcdr (n list x) - (setcdr (nthcdr (1- n) list) x)) - -(defun setelt (seq n x) - (if (consp seq) (setcar (nthcdr n seq) x) (aset seq n x))) - - -;;; Functions omitted: case-clausify, check-do-stepforms, check-do-endforms, -;;; extract-do-inits, extract-do[*]-steps, select-stepping-forms, -;;; elt-satisfies-if[-not]-p, with-keyword-args, mv-bind-clausify, -;;; all names with embedded `$'. - - -(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 c6aae373589..b7c908882ed 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -5,6 +5,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index e4f605d4fd0..4e7ada8851f 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -7,6 +7,7 @@ ;; Created: July 1987 ;; Maintainer: FSF ;; Keywords: lisp, tools +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index b14c879fcf7..db2ae88b8b7 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "deb3495d75c36a222e5238eadb8e347c") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "20c8c875ff1d11dd819e15a1f25afd73") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -277,12 +277,12 @@ Not documented ;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct ;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf ;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method -;;;;;; declare the locally multiple-value-setq multiple-value-bind -;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels -;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist -;;;;;; do* do loop return-from return block etypecase typecase ecase -;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "36cafd5054969b5bb0b1ce6a21605fed") +;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let* +;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq +;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from +;;;;;; return block etypecase typecase ecase case load-time-value +;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp +;;;;;; gensym) "cl-macs" "cl-macs.el" "c10b5cbebb5267291ef15c782c0271a6") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -535,11 +535,6 @@ Not documented \(fn &rest BODY)" nil (quote macro)) -(autoload 'the "cl-macs" "\ -Not documented - -\(fn TYPE FORM)" nil (quote macro)) - (autoload 'declare "cl-macs" "\ Not documented @@ -759,7 +754,7 @@ surrounded by (block NAME ...). ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "ec3ea1c77742734db8496272fe5721be") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "7b7531276ddf8457abecdd487d3cf0b7") ;;; Generated autoloads from cl-seq.el (autoload 'reduce "cl-seq" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 694a06f8338..f6d66c64c7a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -6,6 +6,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -1818,8 +1819,6 @@ Example: (defsetf window-start set-window-start) (defsetf window-width () (store) (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-cutbuffer x-store-cutbuffer t) -(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) (defsetf x-get-selection x-own-selection t) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index a823e9015db..a5070e4acea 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -6,6 +6,7 @@ ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -47,6 +48,7 @@ ;;; this file independent from cl-macs. (defmacro cl-parsing-keywords (kwords other-keys &rest body) + (declare (indent 2) (debug (sexp sexp &rest form))) (cons 'let* (cons (mapcar @@ -83,13 +85,13 @@ (car cl-keys-temp))) '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) (defmacro cl-check-key (x) + (declare (debug edebug-forms)) (list 'if 'cl-key (list 'funcall 'cl-key x) x)) (defmacro cl-check-test-nokey (item x) + (declare (debug edebug-forms)) (list 'cond (list 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test item x)) @@ -100,20 +102,17 @@ (list 'equal item x) (list 'eq item x))))) (defmacro cl-check-test (item x) + (declare (debug edebug-forms)) (list 'cl-check-test-nokey item (list 'cl-check-key x))) (defmacro cl-check-match (x y) + (declare (debug edebug-forms)) (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) (list 'if 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) (list 'if (list 'numberp x) (list 'equal x y) (list 'eq x y)))) -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) - (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key) diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el index acfd3504ec7..776ce5e9ca1 100644 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@ -4,6 +4,7 @@ ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> ;; Keywords: lisp, tools, maint +;; Package: emacs ;; LCD Archive Entry: ;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 38ae511db78..9b275255b27 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -645,7 +645,6 @@ If ALIST is non-nil, the new pairs are prepended to it." (load "cl-loaddefs" nil 'quiet) ;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") (provide 'cl) ;; Things to do after byte-compiler is loaded. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index b8ff3c03ee9..17fcf7ad6c5 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -514,9 +514,9 @@ Applies to the frame whose line point is on in the backtrace." (insert ? ))) (beginning-of-line)) -(put 'debugger-env-macro 'lisp-indent-function 0) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." + (declare (indent 0)) `(save-excursion (if (null (buffer-name debugger-old-buffer)) ;; old buffer deleted diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index d6f717ccda7..3456d1a63fb 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -7,6 +7,7 @@ ;; Author: David Megginson (dmeggins@aix1.uottawa.ca) ;; Maintainer: FSF ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 5a21946183e..e11572dfc62 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -5,6 +5,7 @@ ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> +;; Package: emacs ;; Keywords: extensions lisp @@ -86,25 +87,23 @@ replacing its case-insensitive matches with the literal string in LIGHTER." ;;;###autoload (defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) "Define a new minor mode MODE. -This function defines the associated control variable MODE, keymap MODE-map, -and toggle command MODE. - +This defines the control variable MODE and the toggle command MODE. DOC is the documentation for the mode toggle command. + Optional INIT-VALUE is the initial value of the mode's variable. Optional LIGHTER is displayed in the modeline when the mode is on. -Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. - If it is a list, it is passed to `easy-mmode-define-keymap' - in order to build a valid keymap. It's generally better to use - a separate MODE-map variable than to use this argument. -The above three arguments can be skipped if keyword arguments are -used (see below). - -BODY contains code to execute each time the mode is activated or deactivated. - It is executed after toggling the mode, - and before running the hook variable `MODE-hook'. - Before the actual body code, you can write keyword arguments (alternating - keywords and values). These following keyword arguments are supported (other - keywords will be passed to `defcustom' if the minor mode is global): +Optional KEYMAP is the default keymap bound to the mode keymap. + If non-nil, it should be a variable name (whose value is a keymap), + a keymap, or a list of arguments for `easy-mmode-define-keymap'. + If KEYMAP is a keymap or list, this also defines the variable MODE-map. + +BODY contains code to execute each time the mode is enabled or disabled. + It is executed after toggling the mode, and before running MODE-hook. + Before the actual body code, you can write keyword arguments, i.e. + alternating keywords and values. These following special keywords + are supported (other keywords are passed to `defcustom' if the minor + mode is global): + :group GROUP Custom group name to use in all generated `defcustom' forms. Defaults to MODE without the possible trailing \"-mode\". Don't use this default group name unless you have written a diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 470f0f67779..9992861fc3c 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -5,6 +5,7 @@ ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> +;; Package: emacs ;; This file is part of GNU Emacs. @@ -43,8 +44,6 @@ menus, turn this variable off, otherwise it is probably better to keep it on.") (if (stringp s) (intern s) s)) ;;;###autoload -(put 'easy-menu-define 'lisp-indent-function 'defun) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a menu bar submenu in maps MAPS, according to MENU. @@ -150,6 +149,7 @@ unselectable text. A string consisting solely of hyphens is displayed as a solid horizontal line. A menu item can be a list with the same format as MENU. This is a submenu." + (declare (indent defun)) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 43fb5762647..145498b9059 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4011,18 +4011,16 @@ May only be called from within `edebug-recursive-edit'." -(defvar edebug-eval-mode-map nil - "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") - -(unless edebug-eval-mode-map - (setq edebug-eval-mode-map (make-sparse-keymap)) - (set-keymap-parent edebug-eval-mode-map lisp-interaction-mode-map) - - (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where) - (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item) - (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list) - (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp) - (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp)) +(defvar edebug-eval-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-interaction-mode-map) + (define-key map "\C-c\C-w" 'edebug-where) + (define-key map "\C-c\C-d" 'edebug-delete-eval-item) + (define-key map "\C-c\C-u" 'edebug-update-eval-list) + (define-key map "\C-x\C-e" 'edebug-eval-last-sexp) + (define-key map "\C-j" 'edebug-eval-print-last-sexp) + map) +"Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.") (put 'edebug-eval-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index b573af29ee2..91cb5642fb7 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el index a2b955a280b..0e76f4bb331 100644 --- a/lisp/emacs-lisp/eieio-comp.el +++ b/lisp/emacs-lisp/eieio-comp.el @@ -5,7 +5,8 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 -;; Keywords: oop, lisp, tools +;; Keywords: lisp, tools +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 268d60fc196..12ff23b311f 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 5dc54f5c35e..b58fbfd3f08 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -4,6 +4,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 375ce0bc6d6..ca3850562c8 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, lisp +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index e4c1c50aa8f..e16c3a17438 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -6,6 +6,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.2 ;; Keywords: OO, tools +;; Package: eieio ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index f5e684e1323..048093b858d 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -5,7 +5,7 @@ ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 +;; Version: 1.3 ;; Keywords: OO, lisp ;; This file is part of GNU Emacs. @@ -31,6 +31,11 @@ ;; Emacs running environment. ;; ;; See eieio.texi for complete documentation on using this package. +;; +;; Note: the implementation of the c3 algorithm is based on: +;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan +;; Retrieved from: +;; http://192.220.96.201/dylan/linearization-oopsla96.html ;; There is funny stuff going on with typep and deftype. This ;; is the only way I seem to be able to make this stuff load properly. @@ -44,7 +49,7 @@ (require 'cl) (require 'eieio-comp)) -(defvar eieio-version "1.2" +(defvar eieio-version "1.3" "Current version of EIEIO.") (defun eieio-version () @@ -79,7 +84,7 @@ "*This hook is executed, then cleared each time `defclass' is called.") (defvar eieio-error-unsupported-class-tags nil - "*Non-nil to throw an error if an encountered tag us unsupported. + "Non-nil to throw an error if an encountered tag is unsupported. This may prevent classes from CLOS applications from being used with EIEIO since EIEIO does not support all CLOS tags.") @@ -170,6 +175,13 @@ Stored outright without modifications or stripping.") (defconst method-generic-after 6 "Index into generic :after tag on a method.") (defconst method-num-slots 7 "Number of indexes into a method's vector.") +(defsubst eieio-specialized-key-to-generic-key (key) + "Convert a specialized KEY into a generic method key." + (cond ((eq key method-static) 0) ;; don't convert + ((< key method-num-lists) (+ key 3)) ;; The conversion + (t key) ;; already generic.. maybe. + )) + ;; How to specialty compile stuff. (autoload 'byte-compile-file-form-defmethod "eieio-comp" "This function is used to byte compile methods in a nice way.") @@ -243,8 +255,7 @@ Methods with only primary implementations are executed in an optimized way." )) (defmacro class-option-assoc (list option) - "Return from LIST the found OPTION. -Return nil if it doesn't exist." + "Return from LIST the found OPTION, or nil if it doesn't exist." `(car-safe (cdr (memq ,option ,list)))) (defmacro class-option (class option) @@ -518,7 +529,7 @@ See `defclass' for more information." ;; Make sure the method invocation order is a valid value. (let ((io (class-option-assoc options :method-invocation-order))) - (when (and io (not (member io '(:depth-first :breadth-first)))) + (when (and io (not (member io '(:depth-first :breadth-first :c3)))) (error "Method invocation order %s is not allowed" io) )) @@ -800,11 +811,11 @@ See `defclass' for more information." (defun eieio-perform-slot-validation-for-default (slot spec value skipnil) "For SLOT, signal if SPEC does not match VALUE. If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (let ((val (eieio-default-eval-maybe value))) - (if (and (not eieio-skip-typecheck) - (not (and skipnil (null val))) - (not (eieio-perform-slot-validation spec val))) - (signal 'invalid-slot-type (list slot spec val))))) + (if (and (not (eieio-eval-default-p value)) + (not eieio-skip-typecheck) + (not (and skipnil (null value))) + (not (eieio-perform-slot-validation spec value))) + (signal 'invalid-slot-type (list slot spec value)))) (defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc &optional defaultoverride skipnil) @@ -1340,7 +1351,7 @@ Summary: (if (= key -1) (signal 'wrong-type-argument (list :static 'non-class-arg))) ;; generics are higher - (setq key (+ key 3))) + (setq key (eieio-specialized-key-to-generic-key key))) ;; Put this lambda into the symbol so we can find it (if (byte-code-function-p (car-safe body)) (eieiomt-add method (car-safe body) key argclass) @@ -1516,13 +1527,21 @@ Fills in OBJ's SLOT with its default value." (eieio-default-eval-maybe val)) obj cl 'oref-default)))) +(defsubst eieio-eval-default-p (val) + "Whether the default value VAL should be evaluated for use." + (and (consp val) (symbolp (car val)) (fboundp (car val)))) + (defun eieio-default-eval-maybe (val) "Check VAL, and return what `oref-default' would provide." - ;; check for quoted things, and unquote them - (if (and (listp val) (eq (car val) 'quote)) - (car (cdr val)) - ;; return it verbatim - val)) + (cond + ;; Is it a function call? If so, evaluate it. + ((eieio-eval-default-p val) + (eval val)) + ;;;; check for quoted things, and unquote them + ;;((and (consp val) (eq (car val) 'quote)) + ;; (car (cdr val))) + ;; return it verbatim + (t val))) ;;; Object Set macros ;; @@ -1610,6 +1629,7 @@ SPEC-LIST is of a form similar to `let'. For example: Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." + (declare (indent 2)) ;; Transform the spec-list into a symbol-macrolet spec-list. (let ((mappings (mapcar (lambda (entry) (let ((var (if (listp entry) (car entry) entry)) @@ -1618,8 +1638,6 @@ variable name of the same name as the slot." spec-list))) (append (list 'symbol-macrolet mappings) body))) -(put 'with-slots 'lisp-indent-function 2) - ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -1678,6 +1696,116 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class))) (class-children-fast class)) +(defun eieio-c3-candidate (class remaining-inputs) + "Returns CLASS if it can go in the result now, otherwise nil" + ;; Ensure CLASS is not in any position but the first in any of the + ;; element lists of REMAINING-INPUTS. + (and (not (let ((found nil)) + (while (and remaining-inputs (not found)) + (setq found (member class (cdr (car remaining-inputs))) + remaining-inputs (cdr remaining-inputs))) + found)) + class)) + +(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) + "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. +If a consistent order does not exist, signal an error." + (if (let ((tail remaining-inputs) + (found nil)) + (while (and tail (not found)) + (setq found (car tail) tail (cdr tail))) + (not found)) + ;; If all remaining inputs are empty lists, we are done. + (nreverse reversed-partial-result) + ;; Otherwise, we try to find the next element of the result. This + ;; is achieved by considering the first element of each + ;; (non-empty) input list and accepting a candidate if it is + ;; consistent with the rests of the input lists. + (let* ((found nil) + (tail remaining-inputs) + (next (progn + (while (and tail (not found)) + (setq found (and (car tail) + (eieio-c3-candidate (caar tail) + remaining-inputs)) + tail (cdr tail))) + found))) + (if next + ;; The graph is consistent so far, add NEXT to result and + ;; merge input lists, dropping NEXT from their heads where + ;; applicable. + (eieio-c3-merge-lists + (cons next reversed-partial-result) + (mapcar (lambda (l) (if (eq (first l) next) (rest l) l)) + remaining-inputs)) + ;; The graph is inconsistent, give up + (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) + +(defun eieio-class-precedence-dfs (class) + "Return all parents of CLASS in depth-first order." + (let* ((parents (class-parents-fast class)) + (classes (copy-sequence + (apply #'append + (list class) + (or + (mapcar + (lambda (parent) + (cons parent + (eieio-class-precedence-dfs parent))) + parents) + '((eieio-default-superclass)))))) + (tail classes)) + ;; Remove duplicates. + (while tail + (setcdr tail (delq (car tail) (cdr tail))) + (setq tail (cdr tail))) + classes)) + +(defun eieio-class-precedence-bfs (class) + "Return all parents of CLASS in breadth-first order." + (let ((result) + (queue (or (class-parents-fast class) + '(eieio-default-superclass)))) + (while queue + (let ((head (pop queue))) + (unless (member head result) + (push head result) + (unless (eq head 'eieio-default-superclass) + (setq queue (append queue (or (class-parents-fast head) + '(eieio-default-superclass)))))))) + (cons class (nreverse result))) + ) + +(defun eieio-class-precedence-c3 (class) + "Return all parents of CLASS in c3 order." + (let ((parents (class-parents-fast class))) + (eieio-c3-merge-lists + (list class) + (append + (or + (mapcar + (lambda (x) + (eieio-class-precedence-c3 x)) + parents) + '((eieio-default-superclass))) + (list parents)))) + ) + +(defun class-precedence-list (class) + "Return (transitively closed) list of parents of CLASS. +The order, in which the parents are returned depends on the +method invocation orders of the involved classes." + (if (or (null class) (eq class 'eieio-default-superclass)) + nil + (case (class-method-invocation-order class) + (:depth-first + (eieio-class-precedence-dfs class)) + (:breadth-first + (eieio-class-precedence-bfs class)) + (:c3 + (eieio-class-precedence-c3 class)))) + ) + ;; Official CLOS functions. (defalias 'class-direct-superclasses 'class-parents) (defalias 'class-direct-subclasses 'class-children) @@ -1715,7 +1843,8 @@ The CLOS function `class-direct-subclasses' is aliased to this function." p (cdr p))) (if child t))) -(defun object-slots (obj) "Return list of slots available in OBJ." +(defun object-slots (obj) + "Return list of slots available in OBJ." (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list 'eieio-object-p obj))) (aref (class-v (object-class-fast obj)) class-public-a)) @@ -2009,14 +2138,26 @@ This should only be called from a generic function." keys (append (make-list (length tlambdas) method-before) keys)) ) - ;; If there were no methods found, then there could be :static methods. - (when (not lambdas) + (if mclass + ;; For the case of a class, + ;; if there were no methods found, then there could be :static methods. + (when (not lambdas) + (setq tlambdas + (eieio-generic-form method method-static mclass)) + (setq lambdas (cons tlambdas lambdas) + keys (cons method-static keys) + primarymethodlist ;; Re-use even with bad name here + (eieiomt-method-list method method-static mclass))) + ;; For the case of no class (ie - mclass == nil) then there may + ;; be a primary method. (setq tlambdas - (eieio-generic-form method method-static mclass)) - (setq lambdas (cons tlambdas lambdas) - keys (cons method-static keys) - primarymethodlist ;; Re-use even with bad name here - (eieiomt-method-list method method-static mclass))) + (eieio-generic-form method method-primary nil)) + (when tlambdas + (setq lambdas (cons tlambdas lambdas) + keys (cons method-primary keys) + primarymethodlist + (eieiomt-method-list method method-primary nil))) + ) (run-hook-with-args 'eieio-pre-method-execution-hooks primarymethodlist) @@ -2143,37 +2284,23 @@ CLASS is the starting class to search from in the method tree. If CLASS is nil, then an empty list of methods should be returned." ;; Note: eieiomt - the MT means MethodTree. See more comments below ;; for the rest of the eieiomt methods. - (let ((lambdas nil) - (mclass (list class))) - (while mclass - ;; Note: a nil can show up in the class list once we start - ;; searching through the method tree. - (when (car mclass) - ;; lookup the form to use for the PRIMARY object for the next level - (let ((tmpl (eieio-generic-form method key (car mclass)))) - (when (or (not lambdas) - ;; This prevents duplicates coming out of the - ;; class method optimizer. Perhaps we should - ;; just not optimize before/afters? - (not (eq (car tmpl) (car (car lambdas))))) - (setq lambdas (cons tmpl lambdas)) - (if (null (car lambdas)) - (setq lambdas (cdr lambdas)))))) - ;; Add new classes to mclass. Since our input might not be a class - ;; protect against that. - (if (car mclass) - ;; If there is a class, append any methods it may provide - ;; to the remainder of the class list. - (let ((io (class-method-invocation-order (car mclass)))) - (if (eq io :depth-first) - ;; Depth first. - (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass))) - ;; Breadth first. - (setq mclass (append (cdr mclass) (eieiomt-next (car mclass))))) - ) - ;; Advance to next entry in mclass if it is nil. - (setq mclass (cdr mclass))) - ) + + ;; Collect lambda expressions stored for the class and its parent + ;; classes. + (let (lambdas) + (dolist (ancestor (class-precedence-list class)) + ;; Lookup the form to use for the PRIMARY object for the next level + (let ((tmpl (eieio-generic-form method key ancestor))) + (when (and tmpl + (or (not lambdas) + ;; This prevents duplicates coming out of the + ;; class method optimizer. Perhaps we should + ;; just not optimize before/afters? + (not (member tmpl lambdas)))) + (push tmpl lambdas)))) + + ;; Return collected lambda. For :after methods, return in current + ;; order (most general class last); Otherwise, reverse order. (if (eq key method-after) lambdas (nreverse lambdas)))) @@ -2207,6 +2334,7 @@ Use `next-method-p' to find out if there is a next method to call." (apply 'no-next-method (car newargs) (cdr newargs)) (let* ((eieio-generic-call-next-method-list (cdr eieio-generic-call-next-method-list)) + (eieio-generic-call-arglst newargs) (scoped-class (cdr next)) (fcn (car next)) ) @@ -2299,32 +2427,18 @@ nil for superclasses. This function performs no type checking!" (defun eieiomt-sym-optimize (s) "Find the next class above S which has a function body for the optimizer." - ;; (message "Optimizing %S" s) - (let* ((es (intern-soft (symbol-name s))) ;external symbol of class - (io (class-method-invocation-order es)) - (ov nil) - (cont t)) - ;; This converts ES from a single symbol to a list of parent classes. - (setq es (eieiomt-next es)) - ;; Loop over ES, then its children individually. - ;; We can have multiple hits only at one level of the parent tree. - (while (and es cont) - (setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray)) - (if (fboundp ov) - (progn - (set s ov) ;store ov as our next symbol - (setq cont nil)) - (if (eq io :depth-first) - ;; Pre-pend the subclasses of (car es) so we get - ;; DEPTH FIRST optimization. - (setq es (append (eieiomt-next (car es)) (cdr es))) - ;; Else, we are breadth first. - ;; (message "Class %s is breadth first" es) - (setq es (append (cdr es) (eieiomt-next (car es)))) - ))) - ;; If there is no nearest call, then set our value to nil - (if (not es) (set s nil)) - )) + ;; Set the value to nil in case there is no nearest cell. + (set s nil) + ;; Find the nearest cell that has a function body. If we find one, + ;; we replace the nil from above. + (let ((external-symbol (intern-soft (symbol-name s)))) + (catch 'done + (dolist (ancestor (rest (class-precedence-list external-symbol))) + (let ((ov (intern-soft (symbol-name ancestor) + eieiomt-optimizing-obarray))) + (when (fboundp ov) + (set s ov) ;; store ov as our next symbol + (throw 'done ancestor))))))) (defun eieio-generic-form (method key class) "Return the lambda form belonging to METHOD using KEY based upon CLASS. @@ -2333,7 +2447,7 @@ no form, but has a parent class, then trace to that parent class. The first time a form is requested from a symbol, an optimized path is memorized for faster future use." (let ((emto (aref (get method 'eieio-method-obarray) - (if class key (+ key 3))))) + (if class key (eieio-specialized-key-to-generic-key key))))) (if (class-p class) ;; 1) find our symbol (let ((cs (intern-soft (symbol-name class) emto))) @@ -2366,7 +2480,7 @@ is memorized for faster future use." nil))) ;; for a generic call, what is a list, is the function body we want. (let ((emtl (aref (get method 'eieio-method-tree) - (if class key (+ key 3))))) + (if class key (eieio-specialized-key-to-generic-key key))))) (if emtl ;; The car of EMTL is supposed to be a class, which in this ;; case is nil, so skip it. @@ -2431,6 +2545,11 @@ This is usually a symbol that starts with `:'." (put 'unbound-slot 'error-conditions '(unbound-slot error nil)) (put 'unbound-slot 'error-message "Unbound slot") +(intern "inconsistent-class-hierarchy") +(put 'inconsistent-class-hierarchy 'error-conditions + '(inconsistent-class-hierarchy error nil)) +(put 'inconsistent-class-hierarchy 'error-message "Inconsistent class hierarchy") + ;;; Here are some CLOS items that need the CL package ;; @@ -2526,6 +2645,17 @@ dynamically set from SLOTS." (slot (aref scoped-class class-public-a)) (defaults (aref scoped-class class-public-d))) (while slot + ;; For each slot, see if we need to evaluate it. + ;; + ;; Paul Landes said in an email: + ;; > CL evaluates it if it can, and otherwise, leaves it as + ;; > the quoted thing as you already have. This is by the + ;; > Sonya E. Keene book and other things I've look at on the + ;; > web. + (let ((dflt (eieio-default-eval-maybe (car defaults)))) + (when (not (eq dflt (car defaults))) + (eieio-oset this (car slot) dflt) )) + ;; Next. (setq slot (cdr slot) defaults (cdr defaults)))) ;; Shared initialize will parse our slots for us. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 216d91baa7b..9d59337a7c7 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -213,6 +213,8 @@ LIBRARY should be a string (the name of the library)." (interactive (let* ((dirs (or find-function-source-path load-path)) (suffixes (find-library-suffixes)) + (table (apply-partially 'locate-file-completion-table + dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -226,16 +228,12 @@ LIBRARY should be a string (the name of the library)." (thing-at-point 'symbol)) (error nil)) (thing-at-point 'symbol)))) - (when def - (setq def (and (locate-file-completion-table - dirs suffixes def nil 'lambda) - def))) + (when (and def (not (test-completion def table))) + (setq def nil)) (list (completing-read (if def (format "Library name (default %s): " def) "Library name: ") - (apply-partially 'locate-file-completion-table - dirs suffixes) - nil nil nil nil def)))) + table nil nil nil nil def)))) (let ((buf (find-file-noselect (find-library-name library)))) (condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf))))) diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 6a05bda82ae..371fe8af3ad 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,10 +1,11 @@ ;;; float-sup.el --- define some constants useful for floating point numbers. -;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -25,36 +26,27 @@ ;;; Code: -;; Provide a meaningful error message if we are running on -;; bare (non-float) emacs. +;; Provide an easy hook to tell if we are running with floats or not. +;; Define pi and e via math-lib calls (much less prone to killer typos). +(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") +(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") -(if (fboundp 'atan) - nil - (error "Floating point was disabled at compile time")) +(defconst float-e (exp 1) "The value of e (2.7182818...).") -;; provide an easy hook to tell if we are running with floats or not. -;; define pi and e via math-lib calls. (much less prone to killer typos.) -(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") - -;; It's too inconvenient to make `e' a constant because it's used as -;; a temporary variable all the time. -(defvar e (exp 1) "The value of e (2.7182818...).") - -(defconst degrees-to-radians (/ pi 180.0) +(defconst degrees-to-radians (/ float-pi 180.0) "Degrees to radian conversion constant.") -(defconst radians-to-degrees (/ 180.0 pi) +(defconst radians-to-degrees (/ 180.0 float-pi) "Radian to degree conversion constant.") -;; these expand to a single multiply by a float when byte compiled +;; These expand to a single multiply by a float when byte compiled. (defmacro degrees-to-radians (x) - "Convert ARG from degrees to radians." - (list '* (/ pi 180.0) x)) + "Convert X from degrees to radians." + (list '* degrees-to-radians x)) (defmacro radians-to-degrees (x) - "Convert ARG from radians to degrees." - (list '* (/ 180.0 pi) x)) + "Convert X from radians to degrees." + (list '* radians-to-degrees x)) (provide 'lisp-float-type) -;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d ;;; float-sup.el ends here diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index b6e8427ea1c..51b23c3f402 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -6,6 +6,7 @@ ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Fri Sep 27 1996 ;; Keywords: generic, comment, font-lock +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index b7cb8b93c2f..6a597429328 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -6,6 +6,7 @@ ;; Author: K. Shane Hartman ;; Maintainer: FSF ;; Keywords: help +;; Package: emacs ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 10b7baf294f..7df65acb283 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -298,6 +298,7 @@ The returned value is a list of strings, one per line." (defmacro lm-with-file (file &rest body) "Execute BODY in a buffer containing the contents of FILE. If FILE is nil, execute BODY in the current buffer." + (declare (indent 1) (debug t)) (let ((filesym (make-symbol "file"))) `(let ((,filesym ,file)) (if ,filesym @@ -311,9 +312,6 @@ If FILE is nil, execute BODY in the current buffer." (with-syntax-table emacs-lisp-mode-syntax-table ,@body)))))) -(put 'lm-with-file 'lisp-indent-function 1) -(put 'lm-with-file 'edebug-form-spec t) - ;; Fixme: Probably this should be amalgamated with copyright.el; also ;; we need a check for ranges in copyright years. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 21a9f80fa90..e4330e43fc9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -5,6 +5,7 @@ ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -1209,31 +1210,17 @@ This function also returns nil meaning don't specify the indentation." (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) (put 'save-window-excursion 'lisp-indent-function 0) -(put 'save-selected-window 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) -(put 'with-current-buffer 'lisp-indent-function 1) -(put 'combine-after-change-calls 'lisp-indent-function 0) -(put 'with-output-to-string 'lisp-indent-function 0) -(put 'with-temp-file 'lisp-indent-function 1) -(put 'with-temp-buffer 'lisp-indent-function 0) -(put 'with-temp-message 'lisp-indent-function 1) -(put 'with-syntax-table 'lisp-indent-function 1) (put 'let 'lisp-indent-function 1) (put 'let* 'lisp-indent-function 1) (put 'while 'lisp-indent-function 1) (put 'if 'lisp-indent-function 2) -(put 'read-if 'lisp-indent-function 2) (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) -(put 'eval-after-load 'lisp-indent-function 1) -(put 'dolist 'lisp-indent-function 1) -(put 'dotimes 'lisp-indent-function 1) -(put 'when 'lisp-indent-function 1) -(put 'unless 'lisp-indent-function 1) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index c728abab496..d0d1520a677 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -5,6 +5,7 @@ ;; Maintainer: FSF ;; Keywords: lisp, languages +;; Package: emacs ;; This file is part of GNU Emacs. @@ -140,15 +141,19 @@ A negative argument means move backward but still to a less deep spot. This command assumes point is not in a string or comment." (interactive "^p") (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) + (let ((inc (if (> arg 0) 1 -1)) + pos) (while (/= arg 0) - (if forward-sexp-function + (if (null forward-sexp-function) + (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) (condition-case err - (while (let ((pos (point))) + (while (progn (setq pos (point)) (forward-sexp inc) (/= (point) pos))) (scan-error (goto-char (nth 2 err)))) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))) + (if (= (point) pos) + (signal 'scan-error + (list "Unbalanced parentheses" (point) (point))))) (setq arg (- arg inc))))) (defun kill-sexp (&optional arg) @@ -641,49 +646,49 @@ considered." (defun lisp-completion-at-point (&optional predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." ;; FIXME: the `end' could be after point? - (let* ((pos (point)) - (beg (with-syntax-table emacs-lisp-mode-syntax-table - (condition-case nil - (save-excursion - (backward-sexp 1) - (skip-syntax-forward "'") - (point)) - (scan-error pos)))) - (predicate - (or predicate - (save-excursion - (goto-char beg) - (if (not (eq (char-before) ?\()) - (lambda (sym) ;why not just nil ? -sm - (or (boundp sym) (fboundp sym) - (symbol-plist sym))) - ;; Looks like a funcall position. Let's double check. - (if (condition-case nil - (progn (up-list -2) (forward-char 1) - (eq (char-after) ?\()) - (error nil)) - ;; If the first element of the parent list is an open - ;; parenthesis we are probably not in a funcall position. - ;; Maybe a `let' varlist or something. - nil - ;; Else, we assume that a function name is expected. - 'fboundp))))) - (end - (unless (or (eq beg (point-max)) - (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) - (condition-case nil - (save-excursion - (goto-char beg) - (forward-sexp 1) - (when (>= (point) pos) - (point))) - (scan-error pos))))) - (when end - (list beg end obarray - :predicate predicate - :annotate-function - (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))) + (with-syntax-table emacs-lisp-mode-syntax-table + (let* ((pos (point)) + (beg (condition-case nil + (save-excursion + (backward-sexp 1) + (skip-syntax-forward "'") + (point)) + (scan-error pos))) + (predicate + (or predicate + (save-excursion + (goto-char beg) + (if (not (eq (char-before) ?\()) + (lambda (sym) ;why not just nil ? -sm + (or (boundp sym) (fboundp sym) + (symbol-plist sym))) + ;; Looks like a funcall position. Let's double check. + (if (condition-case nil + (progn (up-list -2) (forward-char 1) + (eq (char-after) ?\()) + (error nil)) + ;; If the first element of the parent list is an open + ;; paren we are probably not in a funcall position. + ;; Maybe a `let' varlist or something. + nil + ;; Else, we assume that a function name is expected. + 'fboundp))))) + (end + (unless (or (eq beg (point-max)) + (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) + (condition-case nil + (save-excursion + (goto-char beg) + (forward-sexp 1) + (when (>= (point) pos) + (point))) + (scan-error pos))))) + (when end + (list beg end obarray + :predicate predicate + :annotate-function + (unless (eq predicate 'fboundp) + (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))) ;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/lmenu.el b/lisp/emacs-lisp/lmenu.el deleted file mode 100644 index 54fb488ed59..00000000000 --- a/lisp/emacs-lisp/lmenu.el +++ /dev/null @@ -1,443 +0,0 @@ -;;; lmenu.el --- emulate Lucid's menubar support - -;; Copyright (C) 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Keywords: emulations obsolete - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - - -;; First, emulate the Lucid menubar support in GNU Emacs 19. - -;; Arrange to use current-menubar to set up part of the menu bar. - -(defvar current-menubar) -(defvar lucid-menubar-map) -(defvar lucid-failing-menubar) - -(defvar recompute-lucid-menubar 'recompute-lucid-menubar) -(defun recompute-lucid-menubar () - (define-key lucid-menubar-map [menu-bar] - (condition-case nil - (make-lucid-menu-keymap "menu-bar" current-menubar) - (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") - (sit-for 1) - (setq lucid-failing-menubar current-menubar - current-menubar nil)))) - (setq lucid-menu-bar-dirty-flag nil)) - -(defvar lucid-menubar-map (make-sparse-keymap)) -(or (assq 'current-menubar minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'current-menubar lucid-menubar-map) - minor-mode-map-alist))) - -;; XEmacs compatibility -(defun set-menubar-dirty-flag () - (force-mode-line-update) - (setq lucid-menu-bar-dirty-flag t)) - -(defvar add-menu-item-count 0) - -;; This is a variable whose value is always nil. -(defvar make-lucid-menu-keymap-disable nil) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -(defun make-lucid-menu-keymap (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let ((item (car menu-items)) - command name callback) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (make-lucid-menu-keymap (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - add-menu-item-count)) - add-menu-item-count (1+ add-menu-item-count) - name (aref item 0) - callback (aref item 1)) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t) - (let ((i 2)) - (while (< i (length item)) - (cond - ((eq (aref item i) ':active) - (put command 'menu-enable - (or (aref item (1+ i)) - 'make-lucid-menu-keymap-disable)) - (setq i (+ 2 i))) - ((eq (aref item i) ':suffix) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':keys) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':style) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':selected) - ;; unimplemented - (setq i (+ 2 i))) - ((and (symbolp (aref item i)) - (= ?: (string-to-char (symbol-name (aref item i))))) - (error "Unrecognized menu item keyword: %S" - (aref item i))) - ((= i 2) - ;; old-style format: active-p &optional suffix - (put command 'menu-enable - (or (aref item i) 'make-lucid-menu-keymap-disable)) - ;; suffix is unimplemented - (setq i (length item))) - (t - (error "Unexpected menu item value: %S" - (aref item i)))))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (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. -A dialog box description is a list. - - - The first element of the list is a string to display in the dialog box. - - The rest of the elements are descriptions of the dialog box's buttons. - Each one is a vector of three elements: - - The first element is the text of the button. - - The second element is the `callback'. - - The third element is t or nil, whether this button is selectable. - -If the `callback' of a button is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -One (and only one) of the buttons may be nil. This marker means that all -following buttons should be flushright instead of flushleft. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t, nil, or a form to evaluate to decide whether this - button should be selectable> - name := <string> - partition := 'nil' - button := '[' name callback active-p ']' - dialog := '(' name [ button ]+ [ partition [ button ]+ ] ')'" - (let ((name (car data)) - (tail (cdr data)) - converted - choice meaning) - (while tail - (if (null (car tail)) - (setq converted (cons nil converted)) - (let ((item (aref (car tail) 0)) - (callback (aref (car tail) 1)) - (enable (aref (car tail) 2))) - (setq converted - (cons (if enable (cons item callback) item) - converted)))) - (setq tail (cdr tail))) - (setq choice (x-popup-dialog t (cons name (nreverse converted)))) - (if choice - (if (symbolp choice) - (call-interactively choice) - (eval choice))))) - -;; This is empty because the usual elements of the menu bar -;; are provided by menu-bar.el instead. -;; It would not make sense to duplicate them here. -(defconst default-menubar nil) - -;; XEmacs compatibility -(defun set-menubar (menubar) - "Set the default menubar to be menubar." - (setq-default current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - -;; XEmacs compatibility -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be menubar." - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - - -;;; menu manipulation functions - -;; XEmacs compatibility -(defun find-menu-item (menubar item-path-list &optional parent) - "Searches MENUBAR for item given by ITEM-PATH-LIST. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -Signals an error if the item is not found." - (or parent (setq item-path-list (mapcar 'downcase item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (downcase (if (vectorp (car rest)) - (aref (car rest) 0) - (if (stringp (car rest)) - (car rest) - (car (car rest))))))) - (setq result (car rest) rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (if (consp result) - (find-menu-item (cdr result) (cdr item-path-list) result) - (if result - (signal 'error (list "not a submenu" result)) - (signal 'error (list "no such submenu" (car item-path-list))))) - (cons result parent))))) - - -;; XEmacs compatibility -(defun disable-menu-item (path) - "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "can't disable menus, only menu items")) - (aset item 2 nil) - (set-menubar-dirty-flag) - item)) - - -;; XEmacs compatibility -(defun enable-menu-item (path) - "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "%S is a menu, not a menu item" path)) - (aset item 2 t) - (set-menubar-dirty-flag) - item)) - - -(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) - (if before (setq before (downcase before))) - (let* ((menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item (if (listp menu) - (car (find-menu-item (cdr menu) (list item-name))) - (signal 'error (list "not a submenu" menu-path))))) - (or menu - (let ((rest menu-path) - (so-far menubar)) - (while rest -;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) - (setq menu - (if (eq so-far menubar) - (car (find-menu-item so-far (list (car rest)))) - (car (find-menu-item (cdr so-far) (list (car rest)))))) - (or menu - (let ((rest2 so-far)) - (or rest2 - (error "Trying to modify a menu that doesn't exist")) - (while (and (cdr rest2) (car (cdr rest2))) - (setq rest2 (cdr rest2))) - (setcdr rest2 - (nconc (list (setq menu (list (car rest)))) - (cdr rest2))))) - (setq so-far menu) - (setq rest (cdr rest))))) - (or menu (setq menu menubar)) - (if item - nil ; it's already there - (if item-p - (setq item (vector item-name item-data enabled-p)) - (setq item (cons item-name item-data))) - ;; if BEFORE is specified, try to add it there. - (if before - (setq before (car (find-menu-item menu (list before))))) - (let ((rest menu) - (added-before nil)) - (while rest - (if (eq before (car (cdr rest))) - (progn - (setcdr rest (cons item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (if (not added-before) - ;; adding before the first item on the menubar itself is harder - (if (and (eq menu menubar) (eq before (car menu))) - (setq menu (cons item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list item)))))) - (if item-p - (progn - (aset item 1 item-data) - (aset item 2 (not (null enabled-p)))) - (setcar item item-name) - (setcdr item item-data)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu-item (menu-path item-name function enabled-p &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -ITEM-NAME is the string naming the menu item to be added. -FUNCTION is the command to invoke when this menu item is selected. - If it is a symbol, then it is invoked with `call-interactively', in the same - way that functions bound to keys are invoked. If it is a list, then the - list is simply evaluated. -ENABLED-P controls whether the item is selectable or not. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (or menu-path (error "must specify a menu path")) - (or item-name (error "must specify an item name")) - (add-menu-item-1 t menu-path item-name function enabled-p before)) - - -;; XEmacs compatibility -(defun delete-menu-item (path) - "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (or (cdr pair) menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq menu current-menubar) - (setq current-menubar (delq item menu)) - (delq item menu)) - (set-menubar-dirty-flag) - item))) - - -;; XEmacs compatibility -(defun relabel-menu-item (path new-name) - "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". -NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (and (consp item) - (stringp (car item))) - (setcar item new-name) - (aset item 0 new-name)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu (menu-path menu-name menu-items &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -MENU-NAME is the string naming the menu to be added. -MENU-ITEMS is a list of menu item descriptions. - Each menu item should be a vector of three elements: - - a string, the name of the menu item; - - a symbol naming a command, or a form to evaluate; - - and a form whose value determines whether this item is selectable. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (or menu-name (error "must specify a menu name")) - (or menu-items (error "must specify some menu items")) - (add-menu-item-1 nil menu-path menu-name menu-items t before)) - - - -(defvar put-buffer-names-in-file-menu t) - - -;; Don't unconditionally enable menu bars; leave that up to the user. -;;(let ((frames (frame-list))) -;; (while frames -;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) -;; (setq frames (cdr frames)))) -;;(or (assq 'menu-bar-lines default-frame-alist) -;; (setq default-frame-alist -;; (cons '(menu-bar-lines . 1) default-frame-alist))) - -(set-menubar default-menubar) - -(provide 'lmenu) - -;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1 -;;; lmenu.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 876b9a468ac..6dfd47b4ad1 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -52,6 +52,7 @@ possible (for instance, when BODY just returns VAR unchanged, the result will be eq to LIST). \(fn (VAR LIST) BODY...)" + (declare (indent 1)) (let ((var (car var+list)) (list (cadr var+list)) (shared (make-symbol "shared")) @@ -72,7 +73,6 @@ result will be eq to LIST). (push ,new-el ,unshared)) (setq ,tail (cdr ,tail))) (nconc (nreverse ,unshared) ,shared)))) -(put 'macroexp-accumulate 'lisp-indent-function 1) (defun macroexpand-all-forms (forms &optional skip) "Return FORMS with macros expanded. FORMS is a list of forms. @@ -107,80 +107,69 @@ Assumes the caller has bound `macroexpand-all-environment'." macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. (setq form (macroexpand form macroexpand-all-environment)) - (if (consp form) - (let ((fun (car form))) - (cond - ((eq fun 'cond) - (maybe-cons fun (macroexpand-all-clauses (cdr form)) form)) - ((eq fun 'condition-case) - (maybe-cons - fun - (maybe-cons (cadr form) - (maybe-cons (macroexpand-all-1 (nth 2 form)) - (macroexpand-all-clauses (nthcdr 3 form) 1) - (cddr form)) - (cdr form)) - form)) - ((eq fun 'defmacro) - (push (cons (cadr form) (cons 'lambda (cddr form))) - macroexpand-all-environment) - (macroexpand-all-forms form 3)) - ((eq fun 'defun) - (macroexpand-all-forms form 3)) - ((memq fun '(defvar defconst)) - (macroexpand-all-forms form 2)) - ((eq fun 'function) - (if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) - (maybe-cons fun - (maybe-cons (macroexpand-all-forms (cadr form) 2) - nil - (cdr form)) - form) - form)) - ((memq fun '(let let*)) - (maybe-cons fun - (maybe-cons (macroexpand-all-clauses (cadr form) 1) - (macroexpand-all-forms (cddr form)) - (cdr form)) - form)) - ((eq fun 'quote) - form) - ((and (consp fun) (eq (car fun) 'lambda)) - ;; Embedded lambda in function position. - (maybe-cons (macroexpand-all-forms fun 2) - (macroexpand-all-forms (cdr form)) - form)) - ;; The following few cases are for normal function calls that - ;; are known to funcall one of their arguments. The byte - ;; compiler has traditionally handled these functions specially - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - ((and (memq fun '(apply mapcar mapatoms mapconcat mapc)) - (consp (cadr form)) - (eq (car (cadr form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cons 'function (cdr (cadr form)))) - (macroexpand-all-forms (cddr form))))) - ;; Second arg is a function: - ((and (eq fun 'sort) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote)) - ;; We don't use `maybe-cons' since there's clearly a change. - (cons fun - (cons (macroexpand-all-1 (cadr form)) - (cons (macroexpand-all-1 - (cons 'function (cdr (nth 2 form)))) - (macroexpand-all-forms (nthcdr 3 form)))))) - (t - ;; For everything else, we just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexpand-all-forms form 1)))) - form))) + (pcase form + (`(cond . ,clauses) + (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) + (maybe-cons + 'condition-case + (maybe-cons err + (maybe-cons (macroexpand-all-1 body) + (macroexpand-all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(defmacro ,name . ,args-and-body) + (push (cons name (cons 'lambda args-and-body)) + macroexpand-all-environment) + (macroexpand-all-forms form 3)) + (`(defun . ,_) (macroexpand-all-forms form 3)) + (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (maybe-cons 'function + (maybe-cons (macroexpand-all-forms f 2) + nil + (cdr form)) + form)) + (`(,(or `function `quote) . ,_) form) + (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) + (maybe-cons fun + (maybe-cons (macroexpand-all-clauses bindings 1) + (macroexpand-all-forms body) + (cdr form)) + form)) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + (maybe-cons (macroexpand-all-forms fun 2) + (macroexpand-all-forms args) + form)) + ;; The following few cases are for normal function calls that + ;; are known to funcall one of their arguments. The byte + ;; compiler has traditionally handled these functions specially + ;; by treating a lambda expression quoted by `quote' as if it + ;; were quoted by `function'. We make the same transformation + ;; here, so that any code that cares about the difference will + ;; see the same transformation. + ;; First arg is a function: + (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 (list 'function f)) + (macroexpand-all-forms args)))) + ;; Second arg is a function: + (`(,(and fun (or `sort)) ,arg1 ',f . ,args) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 arg1) + (cons (macroexpand-all-1 + (list 'function f)) + (macroexpand-all-forms args))))) + (`(,_ . ,_) + ;; For every other list, we just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexpand-all-forms form 1)) + (t form)))) ;;;###autoload (defun macroexpand-all (form &optional environment) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index b93950049e0..38c4d5bbe35 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -6,6 +6,7 @@ ;; Created: 10 Mar 2007 ;; Version: 0.9 ;; Keywords: tools +;; Package: package ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2e8c7dc7d4f..61a2985226d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -216,6 +216,7 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-commentary "lisp-mnt" (&optional file)) (declare-function dired-delete-file "dired" (file &optional recursive trash)) +(defvar url-http-end-of-headers) (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. @@ -259,8 +260,9 @@ packages in `package-directory-list'." ;; Defaults are subdirs named "elpa" in the site-lisp dirs. (let (result) (dolist (f load-path) - (if (equal (file-name-nondirectory f) "site-lisp") - (push (expand-file-name "elpa" f) result))) + (and (stringp f) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) (nreverse result)) "List of additional directories containing Emacs Lisp packages. Each directory name should be absolute. @@ -272,46 +274,35 @@ contrast, `package-user-dir' contains packages for personal use." :group 'package :version "24.1") -(defconst package--builtins-base - ;; We use package-version split here to make sure to pick up the - ;; minor version. - `((emacs . [,(version-to-list emacs-version) nil - "GNU Emacs"]) - (package . [,(version-to-list package-el-version) - nil "Simple package system for GNU Emacs"])) - "Packages which are always built-in.") - -(defvar package--builtins - (delq nil - (append - package--builtins-base - (if (>= emacs-major-version 22) - ;; FIXME: emacs 22 includes tramp, rcirc, maybe - ;; other things... - '((erc . [(5 2) nil "Internet Relay Chat client"]) - ;; The external URL is version 1.15, so make sure the - ;; built-in one looks newer. - (url . [(1 16) nil "URL handling libary"]))) - (if (>= emacs-major-version 23) - '(;; Strangely, nxml-version is missing in Emacs 23. - ;; We pick the merge date as the version. - (nxml . [(20071123) nil "Major mode for XML documents"]) - (bubbles . [(0 5) nil "A puzzle game"]))))) - "Alist of all built-in packages. -Maps the package name to a vector [VERSION REQS DOCSTRING].") +;; The value is precomputed in finder-inf.el, but don't load that +;; until it's needed (i.e. when `package-intialize' is called). +(defvar package--builtins nil + "Alist of built-in packages. +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. + +The vector DESC has the form [VERSION REQS DOCSTRING]. + VERSION is a version list. + REQS is a list of packages (symbols) required by the package. + DOCSTRING is a brief description of the package.") (put 'package--builtins 'risky-local-variable t) -(defvar package-alist package--builtins +(defvar package-alist nil "Alist of all packages available for activation. -This maps the package name to a vector [VERSION REQS DOCSTRING]. +Each element has the form (PKG . DESC), where PKG is a package +name (a symbol) and DESC is a vector that describes the package. -The value is generated by `package-load-descriptor', usually -called via `package-initialize'. For user customizations of -which packages to load/activate, see `package-load-list'.") +The vector DESC has the form [VERSION REQS DOCSTRING]. + VERSION is a version list. + REQS is a list of packages (symbols) required by the package. + DOCSTRING is a brief description of the package. + +This variable is set automatically by `package-load-descriptor', +called via `package-initialize'. To change which packages are +loaded and/or activated, customize `package-load-list'.") (put 'package-archive-contents 'risky-local-variable t) -(defvar package-activated-list - (mapcar #'car package-alist) +(defvar package-activated-list nil "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) @@ -416,16 +407,15 @@ updates `package-alist' and `package-obsolete-alist'." (error "Internal error: could not find directory for %s-%s" name version-str)) ;; Add info node. - (if (file-exists-p (expand-file-name "dir" pkg-dir)) - (progn - ;; FIXME: not the friendliest, but simple. - (require 'info) - (info-initialize) - (setq Info-directory-list (cons pkg-dir Info-directory-list)))) + (when (file-exists-p (expand-file-name "dir" pkg-dir)) + ;; FIXME: not the friendliest, but simple. + (require 'info) + (info-initialize) + (push pkg-dir Info-directory-list)) ;; Add to load path, add autoloads, and activate the package. - (setq load-path (cons pkg-dir load-path)) + (push pkg-dir load-path) (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) - (setq package-activated-list (cons package package-activated-list)) + (push package package-activated-list) ;; Don't return nil. t)) @@ -476,22 +466,22 @@ Return nil if the package could not be activated." (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) (cdr elt)))) ;; Make a new association. - (setq package-obsolete-alist - (cons (cons package (list (cons (package-desc-vers pkg-vec) - pkg-vec))) - package-obsolete-alist))))) + (push (cons package (list (cons (package-desc-vers pkg-vec) + pkg-vec))) + package-obsolete-alist)))) -;; (define-package "emacs" "21.4.1" "GNU Emacs core package.") -;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0"))) (defun define-package (name-str version-string - &optional docstring requirements) + &optional docstring requirements + &rest extra-properties) "Define a new package. NAME is the name of the package, a string. VERSION-STRING is the version of the package, a dotted sequence of integers. DOCSTRING is the optional description. REQUIREMENTS is a list of requirements on other packages. -Each requirement is of the form (OTHER-PACKAGE \"VERSION\")." +Each requirement is of the form (OTHER-PACKAGE \"VERSION\"). + +EXTRA-PROPERTIES is currently unused." (let* ((name (intern name-str)) (pkg-desc (assq name package-alist)) (new-version (version-to-list version-string)) @@ -514,7 +504,7 @@ Each requirement is of the form (OTHER-PACKAGE \"VERSION\")." (setq package-alist (delq pkg-desc package-alist)) (package-mark-obsolete (car pkg-desc) (cdr pkg-desc))) ;; Add package to the alist. - (setq package-alist (cons new-pkg-desc package-alist))) + (push new-pkg-desc package-alist)) ;; You can have two packages with the same version, for instance ;; one in the system package directory and one in your private ;; directory. We just let the first one win. @@ -672,7 +662,19 @@ It will move point to somewhere in the headers." (version-list-<= min-version (package-desc-vers (cdr pkg-desc)))))) -(defun package-compute-transaction (result requirements) +(defun package-compute-transaction (package-list requirements) + "Return a list of packages to be installed, including PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). + +REQUIREMENTS should be a list of additional requirements; each +element in this list should have the form (PACKAGE VERSION), +where PACKAGE is a package name and VERSION is the required +version of that package (as a list). + +This function recursively computes the requirements of the +packages in REQUIREMENTS, and returns a list of all the packages +that must be installed. Packages that are already installed are +not included in this list." (dolist (elt requirements) (let* ((next-pkg (car elt)) (next-version (cadr elt))) @@ -703,25 +705,25 @@ but version %s required" (symbol-name next-pkg) (package-version-join next-version) (package-version-join (package-desc-vers (cdr pkg-desc))))) ;; Only add to the transaction if we don't already have it. - (unless (memq next-pkg result) - (setq result (cons next-pkg result))) - (setq result - (package-compute-transaction result + (unless (memq next-pkg package-list) + (push next-pkg package-list)) + (setq package-list + (package-compute-transaction package-list (package-desc-reqs (cdr pkg-desc)))))))) - result) + package-list) (defun package-read-from-string (str) "Read a Lisp expression from STR. Signal an error if the entire string was not used." (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) (if more-left (error "Can't read whole string") (car read-data)))) @@ -731,48 +733,33 @@ Signal an error if the entire string was not used." Will return the data from the file, or nil if the file does not exist. Will throw an error if the archive version is too new." (let ((filename (expand-file-name file package-user-dir))) - (if (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (package-read-from-string - (buffer-substring-no-properties (point-min) - (point-max))))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is greater than %d - upgrade package.el" - (car contents) package-archive-version)) - (cdr contents)))))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) (defun package-read-all-archive-contents () - "Re-read `archive-contents' and `builtin-packages', if they exist. -Set `package-archive-contents' and `package--builtins' if successful. -Throw an error if the archive version is too new." + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." (dolist (archive package-archives) - (package-read-archive-contents (car archive))) - (let ((builtins (package--read-archive-file "builtin-packages"))) - (if builtins - ;; Version 1 of 'builtin-packages' is a list where the car is - ;; a split emacs version and the cdr is an alist suitable for - ;; package--builtins. - (let ((our-version (version-to-list emacs-version)) - (result package--builtins-base)) - (setq package--builtins - (dolist (elt builtins result) - (if (version-list-<= (car elt) our-version) - (setq result (append (cdr elt) result))))))))) + (package-read-archive-contents (car archive)))) (defun package-read-archive-contents (archive) - "Re-read `archive-contents' and `builtin-packages' for ARCHIVE. -If successful, set `package-archive-contents' and `package--builtins'. + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. If the archive version is too new, signal an error." - (let ((archive-contents (package--read-archive-file - (concat "archives/" archive - "/archive-contents")))) - (if archive-contents - ;; Version 1 of 'archive-contents' is identical to our - ;; internal representation. - ;; TODO: merge archive lists - (dolist (package archive-contents) - (package--add-to-archive-contents package archive))))) + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((dir (concat "archives/" archive)) + (contents-file (concat dir "/archive-contents")) + contents) + (when (setq contents (package--read-archive-file contents-file)) + (dolist (package contents) + (package--add-to-archive-contents package archive))))) (defun package--add-to-archive-contents (package archive) "Add the PACKAGE from the given ARCHIVE if necessary. @@ -786,9 +773,13 @@ Also, add the originating archive to the end of the package vector." (version-list-< (aref existing-package 0) version)) (add-to-list 'package-archive-contents entry)))) -(defun package-download-transaction (transaction) - "Download and install all the packages in the given transaction." - (dolist (elt transaction) +(defun package-download-transaction (package-list) + "Download and install all the packages in PACKAGE-LIST. +PACKAGE-LIST should be a list of package names (symbols). +This function assumes that all package requirements in +PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed +using `package-compute-transaction'." + (dolist (elt package-list) (let* ((desc (cdr (assq elt package-archive-contents))) ;; As an exception, if package is "held" in ;; `package-load-list', download the held version. @@ -839,61 +830,60 @@ Otherwise return nil." v-str)))) (defun package-buffer-info () - "Return a vector of information about the package in the current buffer. -The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] -FILENAME is the file name, a string. It does not have the \".el\" extension. + "Return a vector describing the package in the current buffer. +The vector has the form + + [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] + +FILENAME is the file name, a string, sans the \".el\" extension. REQUIRES is a requires list, or nil. -DESCRIPTION is the package description (a string). +DESCRIPTION is the package description, a string. VERSION is the version, a string. COMMENTARY is the commentary section, a string, or nil if none. -Throws an exception if the buffer does not contain a conforming package. -If there is a package, narrows the buffer to the file's boundaries. -May narrow buffer or move point even on failure." + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." (goto-char (point-min)) - (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) - (let ((file-name (match-string 1)) - (desc (match-string 2)) - (start (progn (beginning-of-line) (point)))) - (if (search-forward (concat ";;; " file-name ".el ends here")) - (progn - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - (requires (if requires-str - (package-read-from-string requires-str))) - ;; Prefer Package-Version, because if it is - ;; defined the package author probably wants us - ;; to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (commentary (lm-commentary))) - (unless pkg-version - (error - "Package does not define a usable \"Version\" or \"Package-Version\" header")) - ;; Turn string version numbers into list form. - (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) - (set-text-properties 0 (length file-name) nil file-name) - (set-text-properties 0 (length pkg-version) nil pkg-version) - (set-text-properties 0 (length desc) nil desc) - (vector file-name requires desc pkg-version commentary))) - (error "Package missing a terminating comment"))) - (error "No starting comment for package"))) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) + (error "Packages lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + (requires (if requires-str + (package-read-from-string requires-str))) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (commentary (lm-commentary))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + ;; Turn string version numbers into list form. + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requires)) + (vector file-name requires desc pkg-version commentary)))) (defun package-tar-file-info (file) "Find package information for a tar file. FILE is the name of the tar file to examine. The return result is a vector like `package-buffer-info'." (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) - (error "`%s' doesn't have a package-ish name" file)) + (error "Invalid package name `%s'" file)) (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) (pkg-version (match-string-no-properties 2 file)) ;; Extract the package descriptor. @@ -904,20 +894,19 @@ The return result is a vector like `package-buffer-info'." pkg-name "-pkg.el"))) (pkg-def-parsed (package-read-from-string pkg-def-contents))) (unless (eq (car pkg-def-parsed) 'define-package) - (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name)) - (let ((name-str (nth 1 pkg-def-parsed)) + (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) (version-string (nth 2 pkg-def-parsed)) - (docstring (nth 3 pkg-def-parsed)) - (requires (nth 4 pkg-def-parsed)) - + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) (readme (shell-command-to-string ;; Requires GNU tar. (concat "tar -xOf " file " " pkg-name "-" pkg-version "/README")))) (unless (equal pkg-version version-string) - (error "Inconsistent versions!")) + (error "Package has inconsistent versions")) (unless (equal pkg-name name-str) - (error "Inconsistent names!")) + (error "Package has inconsistent names")) ;; Kind of a hack. (if (string-match ": Not found in archive" readme) (setq readme nil)) @@ -925,18 +914,27 @@ The return result is a vector like `package-buffer-info'." (if (eq (car requires) 'quote) (setq requires (car (cdr requires)))) (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) + (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + requires)) (vector pkg-name requires docstring version-string readme)))) -(defun package-install-buffer-internal (pkg-info type) +;;;###autoload +(defun package-install-from-buffer (pkg-info type) + "Install a package from the current buffer. +When called interactively, the current buffer is assumed to be a +single .el file that follows the packaging guidelines; see info +node `(elisp)Packaging'. + +When called from Lisp, PKG-INFO is a vector describing the +information, of the type returned by `package-buffer-info'; and +TYPE is the package type (either `single' or `tar')." + (interactive (list (package-buffer-info) 'single)) (save-excursion (save-restriction (let* ((file-name (aref pkg-info 0)) - (requires (aref pkg-info 1)) + (requires (aref pkg-info 1)) (desc (if (string= (aref pkg-info 2) "") "No description available." (aref pkg-info 2))) @@ -956,15 +954,6 @@ The return result is a vector like `package-buffer-info'." (package-initialize))))) ;;;###autoload -(defun package-install-from-buffer () - "Install a package from the current buffer. -The package is assumed to be a single .el file which -follows the elisp comment guidelines; see -info node `(elisp)Library Headers'." - (interactive) - (package-install-buffer-internal (package-buffer-info) 'single)) - -;;;###autoload (defun package-install-file (file) "Install a package from a file. The file can either be a tar file or an Emacs Lisp file." @@ -972,9 +961,10 @@ The file can either be a tar file or an Emacs Lisp file." (with-temp-buffer (insert-file-contents-literally file) (cond - ((string-match "\\.el$" file) (package-install-from-buffer)) + ((string-match "\\.el$" file) + (package-install-from-buffer (package-buffer-info) 'single)) ((string-match "\\.tar$" file) - (package-install-buffer-internal (package-tar-file-info file) 'tar)) + (package-install-from-buffer (package-tar-file-info file) 'tar)) (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) (defun package-delete (name version) @@ -1001,22 +991,27 @@ The file can either be a tar file or an Emacs Lisp file." (re-search-forward "^$" nil 'move) (forward-char) (delete-region (point-min) (point)) - (make-directory dir t) - (setq buffer-file-name (expand-file-name file dir)) - (let ((version-control 'never)) - (save-buffer))) + ;; Read the retrieved buffer to make sure it is valid (e.g. it + ;; may fetch a URL redirect page). + (when (listp (read buffer)) + (make-directory dir t) + (setq buffer-file-name (expand-file-name file dir)) + (let ((version-control 'never)) + (save-buffer)))) (kill-buffer buffer))) (defun package-refresh-contents () "Download the ELPA archive description if needed. -Invoking this will ensure that Emacs knows about the latest versions -of all packages. This will let Emacs make them available for -download." +This informs Emacs about the latest versions of all packages, and +makes them available for download." (interactive) (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) (dolist (archive package-archives) - (package--download-one-archive archive "archive-contents")) + (condition-case nil + (package--download-one-archive archive "archive-contents") + (error (message "Failed to download `%s' archive." + (car archive))))) (package-read-all-archive-contents)) ;;;###autoload @@ -1024,6 +1019,9 @@ download." "Load Emacs Lisp packages, and activate them. The variable `package-load-list' controls which packages to load." (interactive) + (require 'finder-inf nil t) + (setq package-alist package--builtins) + (setq package-activated-list (mapcar #'car package-alist)) (setq package-obsolete-alist nil) (package-load-all-descriptors) (package-read-all-archive-contents) @@ -1052,9 +1050,7 @@ The variable `package-load-list' controls which packages to load." guess) "Describe package: ") packages nil t nil nil guess)) - (list (if (equal val "") - guess - (intern val))))) + (list (if (equal val "") guess (intern val))))) (if (or (null package) (null (symbolp package))) (message "You did not specify a package") (help-setup-xref (list #'describe-package package) @@ -1064,38 +1060,65 @@ The variable `package-load-list' controls which packages to load." (describe-package-1 package))))) (defun describe-package-1 (package) - (let ((desc (cdr (assq package package-alist))) - reqs version installable) + (require 'lisp-mnt) + (let ((package-name (symbol-name package)) + (built-in (assq package package--builtins)) + desc pkg-dir reqs version installable) (prin1 package) (princ " is ") - (cond - (desc - ;; This package is loaded (i.e. in `package-alist'). - (let (pkg-dir) - (setq version (package-version-join (package-desc-vers desc))) - (if (assq package package--builtins) - (princ "a built-in package.\n\n") - (setq pkg-dir (package--dir (symbol-name package) version)) - (if pkg-dir - (progn - (insert "a package installed in `") - (help-insert-xref-button (file-name-as-directory pkg-dir) - 'help-package-def pkg-dir) - (insert "'.\n\n")) - ;; This normally does not happen. - (insert "a deleted package.\n\n") - (setq version nil))))) - (t - ;; An uninstalled package. - (setq desc (cdr (assq package package-archive-contents)) + (if (setq desc (cdr (assq package package-alist))) + ;; This package is loaded (i.e. in `package-alist'). + (progn + (setq version (package-version-join (package-desc-vers desc))) + (cond (built-in + (princ "a built-in package.\n\n")) + ((setq pkg-dir (package--dir package-name version)) + (insert "an installed package.\n\n")) + (t ;; This normally does not happen. + (insert "a deleted package.\n\n") + (setq version nil)))) + ;; This package is not installed. + (setq desc (cdr (assq package package-archive-contents)) version (package-version-join (package-desc-vers desc)) installable t) - (insert "an installable package.\n\n"))) - (if version - (insert " Version: " version "\n")) + (insert "an uninstalled package.\n\n")) + + (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") + (cond (pkg-dir + (insert (propertize "Installed" + 'font-lock-face 'font-lock-comment-face)) + (insert " in `") + ;; Todo: Add button for uninstalling. + (help-insert-xref-button (file-name-as-directory pkg-dir) + 'help-package-def pkg-dir) + (insert "'.")) + (installable + (insert "Available -- ") + (let ((button-text (if (display-graphic-p) + "Install" + "[Install]")) + (button-face (if (display-graphic-p) + '(:box (:line-width 2 :color "dark grey") + :background "light grey" + :foreground "black") + 'link))) + (insert-text-button button-text + 'face button-face + 'follow-link t + 'package-symbol package + 'action 'package-install-button-action))) + (built-in + (insert (propertize "Built-in" + 'font-lock-face 'font-lock-builtin-face) ".")) + (t (insert "Deleted."))) + (insert "\n") + (and version + (> (length version) 0) + (insert " " + (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) (setq reqs (package-desc-reqs desc)) (when reqs - (insert " Requires: ") + (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") (let ((first t) name vers text) (dolist (req reqs) @@ -1110,28 +1133,53 @@ The variable `package-load-list' controls which packages to load." (t (insert ", "))) (help-insert-xref-button text 'help-package name)) (insert "\n"))) - (insert " Description: " (package-desc-doc desc) "\n") - ;; Todo: button for uninstalling a package. - (when installable - (let ((button-text (if (display-graphic-p) - "Install" - "[Install]")) - (button-face (if (display-graphic-p) - '(:box (:line-width 2 :color "dark grey") - :background "light grey" - :foreground "black") - 'link))) - (insert "\n") - (insert-text-button button-text - 'face button-face - 'follow-link t - 'package-symbol package - 'action (lambda (button) - (package-install - (button-get button 'package-symbol)) - (revert-buffer nil t) - (goto-char (point-min)))) - (insert "\n"))))) + (insert " " (propertize "Summary" 'font-lock-face 'bold) + ": " (package-desc-doc desc) "\n\n") + + (if (assq package package--builtins) + ;; For built-in packages, insert the commentary. + (let ((fn (locate-file (concat package-name ".el") load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) + (let ((readme (expand-file-name (concat package-name "-readme.txt") + package-user-dir))) + ;; For elpa packages, try downloading the commentary. If that + ;; fails, try an existing readme file in `package-user-dir'. + (cond ((let ((buffer (ignore-errors + (url-retrieve-synchronously + (concat (package-archive-url package) + package-name "-readme.txt")))) + response) + (when buffer + (with-current-buffer buffer + (setq response (url-http-parse-response)) + (if (or (< response 200) (>= response 300)) + (setq response nil) + (setq buffer-file-name + (expand-file-name readme package-user-dir)) + (delete-region (point-min) (1+ url-http-end-of-headers)) + (save-buffer))) + (when response + (insert-buffer-substring buffer) + (kill-buffer buffer) + t)))) + ((file-readable-p readme) + (insert-file-contents readme) + (goto-char (point-max)))))))) + +(defun package-install-button-action (button) + (let ((package (button-get button 'package-symbol))) + (when (y-or-n-p (format "Install package `%s'? " package)) + (package-install package) + (revert-buffer nil t) + (goto-char (point-min))))) ;;;; Package menu mode. @@ -1148,12 +1196,14 @@ The variable `package-load-list' controls which packages to load." (define-key map "\177" 'package-menu-backup-unmark) (define-key map "d" 'package-menu-mark-delete) (define-key map "i" 'package-menu-mark-install) - (define-key map "g" 'package-menu-revert) + (define-key map "g" 'revert-buffer) (define-key map "r" 'package-menu-refresh) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) - (define-key map "?" 'package-menu-view-commentary) + (define-key map "?" 'package-menu-describe-package) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'mouse-select-window) (define-key map [menu-bar package-menu] (cons "Package" menu-map)) (define-key menu-map [mq] '(menu-item "Quit" quit-window @@ -1180,7 +1230,7 @@ The variable `package-load-list' controls which packages to load." :help "Mark a package for installation and move to the next line")) (define-key menu-map [s3] '("--")) (define-key menu-map [mg] - '(menu-item "Update package list" package-menu-revert + '(menu-item "Update package list" revert-buffer :help "Update the list of packages")) (define-key menu-map [mr] '(menu-item "Refresh package list" package-menu-refresh @@ -1205,6 +1255,7 @@ The variable `package-load-list' controls which packages to load." (defvar package-menu-sort-button-map (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] 'package-menu-sort-by-column) + (define-key map [header-line mouse-2] 'package-menu-sort-by-column) (define-key map [follow-link] 'mouse-face) map) "Local keymap for package menu sort buttons.") @@ -1222,25 +1273,52 @@ Letters do not insert themselves; instead, they are commands. (setq mode-name "Package Menu") (setq truncate-lines t) (setq buffer-read-only t) - ;; Support Emacs 21. - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'package-menu-mode-hook) - (run-hooks 'package-menu-mode-hook))) + (set (make-local-variable 'revert-buffer-function) 'package-menu-revert) + (setq header-line-format + (mapconcat + (lambda (pair) + (let ((column (car pair)) + (name (cdr pair))) + (concat + ;; Insert a space that aligns the button properly. + (propertize " " 'display (list 'space :align-to column) + 'face 'fixed-pitch) + ;; Set up the column button. + (propertize name + 'column-name name + 'help-echo "mouse-1: sort by column" + 'mouse-face 'highlight + 'keymap package-menu-sort-button-map)))) + ;; We take a trick from buff-menu and have a dummy leading + ;; space to align the header line with the beginning of the + ;; text. This doesn't really work properly on Emacs 21, but + ;; it is close enough. + '((0 . "") + (2 . "Package") + (20 . "Version") + (32 . "Status") + (43 . "Description")) + "")) + (run-mode-hooks 'package-menu-mode-hook)) (defun package-menu-refresh () - "Download the ELPA archive. -This fetches the file describing the current contents of -the Emacs Lisp Package Archive, and then refreshes the -package menu. This lets you see what new packages are -available for download." + "Download the Emacs Lisp package archive. +This fetches the contents of each archive specified in +`package-archives', and then refreshes the package menu." (interactive) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) (package-refresh-contents) - (package-list-packages-internal)) + (package--generate-package-list)) -(defun package-menu-revert () - "Update the list of packages." +(defun package-menu-revert (&optional arg noconfirm) + "Update the list of packages. +This function is the `revert-buffer-function' for Package Menu +buffers. The arguments are ignored." (interactive) - (package-list-packages-internal)) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) + (package--generate-package-list)) (defun package-menu-describe-package () "Describe the package in the current line." @@ -1297,32 +1375,8 @@ available for download." (interactive) (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) -(defun package-menu-view-commentary () - "Display information about this package. -For single-file packages, shows the commentary section from the header. -For larger packages, shows the README file." - (interactive) - (let* ((pkg-name (package-menu-get-package)) - (buffer (url-retrieve-synchronously - (concat (package-archive-url pkg-name) - pkg-name - "-readme.txt"))) - start-point ok) - (with-current-buffer buffer - ;; FIXME: it would be nice to work with any URL type. - (setq start-point url-http-end-of-headers) - (setq ok (eq (url-http-parse-response) 200))) - (let ((new-buffer (get-buffer-create "*Package Info*"))) - (with-current-buffer new-buffer - (let ((buffer-read-only nil)) - (erase-buffer) - (insert "Package information for " pkg-name "\n\n") - (if ok - (insert-buffer-substring buffer start-point) - (insert "This package lacks a README file or commentary.\n")) - (goto-char (point-min)) - (view-mode))) - (display-buffer new-buffer t)))) +(define-obsolete-function-alias + 'package-menu-view-commentary 'package-menu-describe-package "24.1") ;; Return the name of the package on the current line. (defun package-menu-get-package () @@ -1405,151 +1459,161 @@ Emacs." (defun package-list-maybe-add (package version status description result) (unless (assoc (cons package version) result) - (setq result (cons (list (cons package version) status description) - result))) + (push (list (cons package version) status description) result)) result) -;; This decides how we should sort; nil means by package name. -(defvar package-menu-sort-key nil) +(defvar package-menu-package-list nil + "List of packages to display in the Package Menu buffer. +A value of nil means to display all packages.") -(defun package-list-packages-internal () - (package-initialize) ; FIXME: do this here? - (with-current-buffer (get-buffer-create "*Packages*") +(defvar package-menu-sort-key nil + "Sort key for the current Package Menu buffer.") + +(defun package--generate-package-list () + "Populate the current Package Menu buffer." + (package-initialize) + (let ((inhibit-read-only t) + info-list name desc hold builtin) (setq buffer-read-only nil) (erase-buffer) - (let ((info-list) - name desc hold - builtin) - ;; List installed packages - (dolist (elt package-alist) - ;; Ignore the Emacs package. - (setq name (car elt) - desc (cdr elt) - hold (assq name package-load-list)) - (unless (eq name 'emacs) - (setq info-list - (package-list-maybe-add - name (package-desc-vers desc) - ;; FIXME: it turns out to be tricky to see if this - ;; package is presently activated. - (cond ((stringp (cadr hold)) - "held") - ((and (setq builtin (assq name package--builtins)) - (version-list-= - (package-desc-vers (cdr builtin)) - (package-desc-vers desc))) - "built-in") - (t "installed")) - (package-desc-doc desc) - info-list)))) - ;; List available packages - (dolist (elt package-archive-contents) - (setq name (car elt) - desc (cdr elt) - hold (assq name package-load-list)) - (unless (and hold (stringp (cadr hold)) - (package-installed-p - name (version-to-list (cadr hold)))) - (setq info-list - (package-list-maybe-add name - (package-desc-vers desc) - (if (and hold (null (cadr hold))) - "disabled" - "available") - (package-desc-doc (cdr elt)) - info-list)))) - ;; List obsolete packages - (mapc (lambda (elt) - (mapc (lambda (inner-elt) - (setq info-list - (package-list-maybe-add (car elt) - (package-desc-vers - (cdr inner-elt)) - "obsolete" - (package-desc-doc - (cdr inner-elt)) - info-list))) - (cdr elt))) - package-obsolete-alist) - (let ((selector (cond - ((string= package-menu-sort-key "Version") - ;; FIXME this doesn't work. - #'(lambda (e) (cdr (car e)))) - ((string= package-menu-sort-key "Status") - #'(lambda (e) (car (cdr e)))) - ((string= package-menu-sort-key "Description") - #'(lambda (e) (car (cdr (cdr e))))) - (t ; "Package" is default. - #'(lambda (e) (symbol-name (car (car e)))))))) + ;; List installed packages + (dolist (elt package-alist) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or (null package-menu-package-list) + (memq name package-menu-package-list))) + (setq desc (cdr elt) + hold (cadr (assq name package-load-list)) + builtin (cdr (assq name package--builtins))) + (setq info-list + (package-list-maybe-add + name (package-desc-vers desc) + ;; FIXME: it turns out to be tricky to see if this + ;; package is presently activated. + (cond ((stringp hold) "held") + ((and builtin + (version-list-= + (package-desc-vers builtin) + (package-desc-vers desc))) + "built-in") + (t "installed")) + (package-desc-doc desc) + info-list)))) + + ;; List available and disabled packages + (dolist (elt package-archive-contents) + (setq name (car elt) + desc (cdr elt) + hold (assq name package-load-list)) + (when (or (null package-menu-package-list) + (memq name package-menu-package-list)) (setq info-list - (sort info-list - (lambda (left right) - (let ((vleft (funcall selector left)) - (vright (funcall selector right))) - (string< vleft vright)))))) - (mapc (lambda (elt) - (package-print-package (car (car elt)) - (cdr (car elt)) - (car (cdr elt)) - (car (cdr (cdr elt))))) - info-list)) + (package-list-maybe-add name + (package-desc-vers desc) + (if (and hold (null (cadr hold))) + "disabled" + "available") + (package-desc-doc (cdr elt)) + info-list)))) + ;; List obsolete packages + (mapc (lambda (elt) + (mapc (lambda (inner-elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers + (cdr inner-elt)) + "obsolete" + (package-desc-doc + (cdr inner-elt)) + info-list))) + (cdr elt))) + package-obsolete-alist) + + (setq info-list + (sort info-list + (cond ((string= package-menu-sort-key "Package") + 'package-menu--name-predicate) + ((string= package-menu-sort-key "Version") + 'package-menu--version-predicate) + ((string= package-menu-sort-key "Description") + 'package-menu--description-predicate) + (t ; By default, sort by package status + 'package-menu--status-predicate)))) + + (dolist (elt info-list) + (package-print-package (car (car elt)) + (cdr (car elt)) + (car (cdr elt)) + (car (cdr (cdr elt))))) (goto-char (point-min)) + (set-buffer-modified-p nil) (current-buffer))) +(defun package-menu--version-predicate (left right) + (let ((vleft (or (cdr (car left)) '(0))) + (vright (or (cdr (car right)) '(0)))) + (if (version-list-= vleft vright) + (package-menu--name-predicate left right) + (version-list-< vleft vright)))) + +(defun package-menu--status-predicate (left right) + (let ((sleft (cadr left)) + (sright (cadr right))) + (cond ((string= sleft sright) + (package-menu--name-predicate left right)) + ((string= sleft "available") t) + ((string= sright "available") nil) + ((string= sleft "installed") t) + ((string= sright "installed") nil) + ((string= sleft "held") t) + ((string= sright "held") nil) + ((string= sleft "built-in") t) + ((string= sright "built-in") nil) + ((string= sleft "obsolete") t) + ((string= sright "obsolete") nil) + (t (string< sleft sright))))) + +(defun package-menu--description-predicate (left right) + (let ((sleft (car (cddr left))) + (sright (car (cddr right)))) + (if (string= sleft sright) + (package-menu--name-predicate left right) + (string< sleft sright)))) + +(defun package-menu--name-predicate (left right) + (string< (symbol-name (caar left)) + (symbol-name (caar right)))) + (defun package-menu-sort-by-column (&optional e) - "Sort the package menu by the last column clicked on." - (interactive (list last-input-event)) - (if e (mouse-select-window e)) + "Sort the package menu by the column of the mouse click E." + (interactive "e") (let* ((pos (event-start e)) (obj (posn-object pos)) (col (if obj (get-text-property (cdr obj) 'column-name (car obj)) - (get-text-property (posn-point pos) 'column-name)))) - (setq package-menu-sort-key col)) - (package-list-packages-internal)) - -(defun package--list-packages () - "Display a list of packages. -Helper function that does all the work for the user-facing functions." - (with-current-buffer (package-list-packages-internal) + (get-text-property (posn-point pos) 'column-name))) + (buf (window-buffer (posn-window (event-start e))))) + (with-current-buffer buf + (when (eq major-mode 'package-menu-mode) + (setq package-menu-sort-key col) + (package--generate-package-list))))) + +(defun package--list-packages (&optional packages) + "Generate and pop to the *Packages* buffer. +Optional PACKAGES is a list of names of packages (symbols) to +list; the default is to display everything in `package-alist'." + (with-current-buffer (get-buffer-create "*Packages*") (package-menu-mode) - ;; Set up the header line. - (setq header-line-format - (mapconcat - (lambda (pair) - (let ((column (car pair)) - (name (cdr pair))) - (concat - ;; Insert a space that aligns the button properly. - (propertize " " 'display (list 'space :align-to column) - 'face 'fixed-pitch) - ;; Set up the column button. - (if (string= name "Version") - name - (propertize name - 'column-name name - 'help-echo "mouse-1: sort by column" - 'mouse-face 'highlight - 'keymap package-menu-sort-button-map))))) - ;; We take a trick from buff-menu and have a dummy leading - ;; space to align the header line with the beginning of the - ;; text. This doesn't really work properly on Emacs 21, - ;; but it is close enough. - '((0 . "") - (2 . "Package") - (20 . "Version") - (32 . "Status") - (43 . "Description")) - "")) - + (set (make-local-variable 'package-menu-package-list) packages) + (set (make-local-variable 'package-menu-sort-key) nil) + (package--generate-package-list) ;; It's okay to use pop-to-buffer here. The package menu buffer - ;; has keybindings, and the user just typed 'M-x - ;; package-list-packages', suggesting that they might want to use - ;; them. + ;; has keybindings, and the user just typed `M-x list-packages', + ;; suggesting that they might want to use them. (pop-to-buffer (current-buffer)))) ;;;###autoload -(defun package-list-packages () +(defun list-packages () "Display a list of packages. Fetches the updated list of packages before displaying. The list is displayed in a buffer named `*Packages*'." @@ -1557,6 +1621,9 @@ The list is displayed in a buffer named `*Packages*'." (package-refresh-contents) (package--list-packages)) +;;;###autoload +(defalias 'package-list-packages 'list-packages) + (defun package-list-packages-no-fetch () "Display a list of packages. Does not fetch the updated list of packages before displaying. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0b46eb2a301..b922e0b0233 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -76,8 +76,8 @@ BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." (if (null bindings) body `(pcase ,(cadr (car bindings)) - (,(caar bindings) (plet* ,(cdr bindings) ,body)) - (t (error "Pattern match failure in `plet'"))))) + (,(caar bindings) (pcase-let* ,(cdr bindings) ,body)) + (t (error "Pattern match failure in `pcase-let'"))))) ;;;###autoload (defmacro pcase-let (bindings body) @@ -85,13 +85,14 @@ of the form (UPAT EXP)." BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." (if (null (cdr bindings)) - `(plet* ,bindings ,body) + `(pcase-let* ,bindings ,body) (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings)) `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding))) bindings) - (plet* ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding))) - bindings) - ,body)))) + (pcase-let* + ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding))) + bindings) + ,body)))) (defun pcase-expand (exp cases) (let* ((defs (if (symbolp exp) '() @@ -290,9 +291,13 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase-split-memq (elems pat) ;; Based on pcase-split-eq. (cond - ;; The same match will give the same result. + ;; The same match will give the same result, but we don't know how + ;; to check it. + ;; (??? + ;; (cons :pcase-succeed nil)) + ;; A match for one of the elements may succeed or fail. ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) - (cons :pcase-succeed nil)) + nil) ;; A different match will fail if this one succeeds. ((and (eq (car-safe pat) '\`) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) @@ -383,18 +388,20 @@ and otherwise defers to REST which is a list of branches of the form `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. - (vs (pcase-fgrep (mapcar #'car vars) exp))) - (if vs - ;; Let's not replace `vars' in `exp' since it's - ;; too difficult to do it right, instead just - ;; let-bind `vars' around `exp'. - `(let ,(mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs) - ;; FIXME: `vars' can capture `sym'. E.g. - ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) - (,@exp ,sym)) - `(,@exp ,sym)))) + (vs (pcase-fgrep (mapcar #'car vars) exp)) + (call (if (functionp exp) + `(,exp ,sym) `(,@exp ,sym)))) + (if (null vs) + call + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let ,(mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs) + ;; FIXME: `vars' can capture `sym'. E.g. + ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) + ,call)))) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) ((symbolp upat) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 78eba19a253..116d7b93d90 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -96,19 +96,24 @@ The returned regexp is typically more efficient than the equivalent regexp: (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) If PAREN is `words', then the resulting regexp is additionally surrounded -by \\=\\< and \\>." +by \\=\\< and \\>. +If PAREN is `symbols', then the resulting regexp is additionally surrounded +by \\=\\_< and \\_>." (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) (max-specpdl-size 10000) (completion-ignore-case nil) (completion-regexp-list nil) - (words (eq paren 'words)) (open (cond ((stringp paren) paren) (paren "\\("))) (sorted-strings (delete-dups (sort (copy-sequence strings) 'string-lessp))) (re (regexp-opt-group sorted-strings (or open t) (not open)))) - (if words (concat "\\<" re "\\>") re)))) + (cond ((eq paren 'words) + (concat "\\<" re "\\>")) + ((eq paren 'symbols) + (concat "\\_<" re "\\_>")) + (t re))))) ;;;###autoload (defun regexp-opt-depth (regexp) @@ -120,7 +125,7 @@ This means the number of non-shy regexp grouping constructs (string-match regexp "") ;; Count the number of open parentheses in REGEXP. (let ((count 0) start last) - (while (string-match "\\\\(\\(\\?:\\)?" regexp start) + (while (string-match "\\\\(\\(\\?[0-9]*:\\)?" regexp start) (setq start (match-end 0)) ; Start of next search. (when (and (not (match-beginning 1)) (subregexp-context-p regexp (match-beginning 0) last)) @@ -136,11 +141,10 @@ This means the number of non-shy regexp grouping constructs (require 'cl)) (defun regexp-opt-group (strings &optional paren lax) - ;; Return a regexp to match a string in the sorted list STRINGS. - ;; If PAREN non-nil, output regexp parentheses around returned regexp. - ;; If LAX non-nil, don't output parentheses if it doesn't require them. - ;; Merges keywords to avoid backtracking in Emacs' regexp matcher. - + "Return a regexp to match a string in the sorted list STRINGS. +If PAREN non-nil, output regexp parentheses around returned regexp. +If LAX non-nil, don't output parentheses if it doesn't require them. +Merges keywords to avoid backtracking in Emacs' regexp matcher." ;; The basic idea is to find the shortest common prefix or suffix, remove it ;; and recurse. If there is no prefix, we divide the list into two so that ;; \(at least) one half will have at least a one-character common prefix. @@ -234,9 +238,7 @@ This means the number of non-shy regexp grouping constructs (defun regexp-opt-charset (chars) - ;; - ;; Return a regexp to match a character in CHARS. - ;; + "Return a regexp to match a character in CHARS." ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 85fe3514b01..522d452c2dc 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -427,7 +427,7 @@ Only both edges of each range is checked." (mapcar (lambda (e) (cond ((= (car e) (cdr e)) (list (car e))) - ;; ((= (1+ (car e)) (cdr e)) (list (car e) (cdr e))) + ((= (1+ (car e)) (cdr e)) (list (car e) (cdr e))) ((list e)))) l)) (delete-dups str)))) @@ -545,7 +545,10 @@ ARG is optional." ((numberp e) (string e)) ((consp e) (if (and (= (1+ (car e)) (cdr e)) - (null (memq (car e) '(?\] ?-)))) + ;; rx-any-condense-range should + ;; prevent this case from happening. + (null (memq (car e) '(?\] ?-))) + (null (memq (cdr e) '(?\] ?-)))) (string (car e) (cdr e)) (string (car e) ?- (cdr e)))) (e))) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index a41db864a1b..e690cbaa1bc 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -24,7 +24,7 @@ ;;; Commentary: -;; The functions in this file detect (`find-emacs-lisp-shadows') +;; The functions in this file detect (`load-path-shadows-find') ;; and display (`list-load-path-shadows') potential load-path ;; problems that arise when Emacs Lisp files "shadow" each other. ;; @@ -53,16 +53,19 @@ (defgroup lisp-shadow nil "Locate Emacs Lisp file shadowings." - :prefix "shadows-" + :prefix "load-path-shadows-" :group 'lisp) -(defcustom shadows-compare-text-p nil +(define-obsolete-variable-alias 'shadows-compare-text-p + 'load-path-shadows-compare-text "23.3") + +(defcustom load-path-shadows-compare-text nil "If non-nil, then shadowing files are reported only if their text differs. This is slower, but filters out some innocuous shadowing." :type 'boolean :group 'lisp-shadow) -(defun find-emacs-lisp-shadows (&optional path) +(defun load-path-shadows-find (&optional path) "Return a list of Emacs Lisp files that create shadows. This function does the work for `list-load-path-shadows'. @@ -124,11 +127,11 @@ See the documentation for `list-load-path-shadows' for further information." ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" file)) (base2 (concat dir "/" file))) - (if (not (and shadows-compare-text-p - (shadow-same-file-or-nonexistent + (if (not (and load-path-shadows-compare-text + (load-path-shadows-same-file-or-nonexistent (concat base1 ".el") (concat base2 ".el")) ;; This is a bit strict, but safe. - (shadow-same-file-or-nonexistent + (load-path-shadows-same-file-or-nonexistent (concat base1 ".elc") (concat base2 ".elc")))) (setq shadows (append shadows (list base1 base2))))) @@ -138,9 +141,12 @@ See the documentation for `list-load-path-shadows' for further information." ;; Return the list of shadowings. shadows)) +(define-obsolete-function-alias 'find-emacs-lisp-shadows + 'load-path-shadows-find "23.3") + ;; Return true if neither file exists, or if both exist and have identical ;; contents. -(defun shadow-same-file-or-nonexistent (f1 f2) +(defun load-path-shadows-same-file-or-nonexistent (f1 f2) (let ((exists1 (file-exists-p f1)) (exists2 (file-exists-p f2))) (or (and (not exists1) (not exists2)) @@ -151,6 +157,34 @@ See the documentation for `list-load-path-shadows' for further information." (and (= (nth 7 (file-attributes f1)) (nth 7 (file-attributes f2))) (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) + +(defvar load-path-shadows-font-lock-keywords + `((,(format "hides \\(%s.*\\)" + (file-name-directory (locate-library "simple.el"))) + . (1 font-lock-warning-face))) + "Keywords to highlight in `load-path-shadows-mode'.") + +(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" + "Major mode for load-path shadows buffer." + (set (make-local-variable 'font-lock-defaults) + '((load-path-shadows-font-lock-keywords))) + (setq buffer-undo-list t + buffer-read-only t)) + +;; TODO use text-properties instead, a la dired. +(require 'button) +(define-button-type 'load-path-shadows-find-file + 'follow-link t +;; 'face 'default + 'action (lambda (button) + (let ((file (concat (button-get button 'shadow-file) ".el"))) + (or (file-exists-p file) + (setq file (concat file ".gz"))) + (if (file-readable-p file) + (pop-to-buffer (find-file-noselect file)) + (error "Cannot read file")))) + 'help-echo "mouse-2, RET: find this file") + ;;;###autoload (defun list-load-path-shadows (&optional stringp) @@ -193,7 +227,7 @@ XXX.elc in an early directory \(that does not contain XXX.el\) is considered to shadow a later file XXX.el, and vice-versa. Shadowings are located by calling the (non-interactive) companion -function, `find-emacs-lisp-shadows'." +function, `load-path-shadows-find'." (interactive) (let* ((path (copy-sequence load-path)) (tem path) @@ -217,7 +251,7 @@ function, `find-emacs-lisp-shadows'." (setq tem nil))) (setq tem (cdr tem))))) - (let* ((shadows (find-emacs-lisp-shadows path)) + (let* ((shadows (load-path-shadows-find path)) (n (/ (length shadows) 2)) (msg (format "%s Emacs Lisp load-path shadowing%s found" (if (zerop n) "No" (concat "\n" (number-to-string n))) @@ -234,14 +268,21 @@ function, `find-emacs-lisp-shadows'." ;; Create the *Shadows* buffer and display shadowings there. (let ((string (buffer-string))) (with-current-buffer (get-buffer-create "*Shadows*") - (fundamental-mode) ;run after-change-major-mode-hook. (display-buffer (current-buffer)) - (setq buffer-undo-list t - buffer-read-only nil) - (erase-buffer) - (insert string) - (insert msg "\n") - (setq buffer-read-only t))) + (load-path-shadows-mode) ; run after-change-major-mode-hook + (let ((inhibit-read-only t)) + (erase-buffer) + (insert string) + (insert msg "\n") + (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)" + nil t) + (dotimes (i 2) + (make-button (match-beginning (1+ i)) + (match-end (1+ i)) + 'type 'load-path-shadows-find-file + 'shadow-file + (match-string (1+ i))))) + (goto-char (point-max))))) ;; We are non-interactive, print shadows via message. (unless (zerop n) (message "This site has duplicate Lisp libraries with the same name. @@ -259,5 +300,4 @@ version unless you know what you are doing.\n") (provide 'shadow) -;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 ;;; shadow.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 2fbf0628dbe..4f5b2046150 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -75,6 +75,26 @@ ;;; Building precedence level tables from BNF specs. +;; We have 4 different representations of a "grammar": +;; - a BNF table, which is a list of BNF rules of the form +;; (NONTERM RHS1 ... RHSn) where each RHS is a list of terminals (tokens) +;; or nonterminals. Any element in these lists which does not appear as +;; the `car' of a BNF rule is taken to be a terminal. +;; - A list of precedences (key word "precs"), is a list, sorted +;; from lowest to highest precedence, of precedence classes that +;; have the form (ASSOCIATIVITY TERMINAL1 .. TERMINALn), where +;; ASSOCIATIVITY can be `assoc', `left', `right' or `nonassoc'. +;; - a 2 dimensional precedence table (key word "prec2"), is a 2D +;; table recording the precedence relation (can be `<', `=', `>', or +;; nil) between each pair of tokens. +;; - a precedence-level table (key word "levels"), while is a alist +;; giving for each token its left and right precedence level (a +;; number or nil). This is used in `smie-op-levels'. +;; The prec2 tables are only intermediate data structures: the source +;; code normally provides a mix of BNF and precs tables, and then +;; turns them into a levels table, which is what's used by the rest of +;; the SMIE code. + (defun smie-set-prec2tab (table x y val &optional override) (assert (and x y)) (let* ((key (cons x y)) @@ -118,7 +138,12 @@ one of those elements share the same precedence level and associativity." (let ((prec2 (make-hash-table :test 'equal))) (dolist (table tables) (maphash (lambda (k v) - (smie-set-prec2tab prec2 (car k) (cdr k) v)) + (if (consp k) + (smie-set-prec2tab prec2 (car k) (cdr k) v) + (if (and (gethash k prec2) + (not (equal (gethash k prec2) v))) + (error "Conflicting values for %s property" k) + (puthash k v prec2)))) table)) prec2))) @@ -139,7 +164,8 @@ one of those elements share the same precedence level and associativity." (last-nts ()) (first-nts ())) (dolist (rhs (cdr rules)) - (assert (consp rhs)) + (unless (consp rhs) + (signal 'wrong-type-argument `(consp ,rhs))) (if (not (member (car rhs) nts)) (pushnew (car rhs) first-ops) (pushnew (car rhs) first-nts) @@ -204,16 +230,156 @@ one of those elements share the same precedence level and associativity." '= override))) (t (smie-set-prec2tab prec2 (car rhs) (cadr rhs) '= override))) (setq rhs (cdr rhs))))) + ;; Keep track of which tokens are openers/closer, so they can get a nil + ;; precedence in smie-prec2-levels. + (puthash :smie-open/close-alist (smie-bnf-classify bnf) prec2) prec2)) +;; (defun smie-prec2-closer-alist (prec2 include-inners) +;; "Build a closer-alist from a PREC2 table. +;; The return value is in the same form as `smie-closer-alist'. +;; INCLUDE-INNERS if non-nil means that inner keywords will be included +;; in the table, e.g. the table will include things like (\"if\" . \"else\")." +;; (let* ((non-openers '()) +;; (non-closers '()) +;; ;; For each keyword, this gives the matching openers, if any. +;; (openers (make-hash-table :test 'equal)) +;; (closers '()) +;; (done nil)) +;; ;; First, find the non-openers and non-closers. +;; (maphash (lambda (k v) +;; (unless (or (eq v '<) (member (cdr k) non-openers)) +;; (push (cdr k) non-openers)) +;; (unless (or (eq v '>) (member (car k) non-closers)) +;; (push (car k) non-closers))) +;; prec2) +;; ;; Then find the openers and closers. +;; (maphash (lambda (k _) +;; (unless (member (car k) non-openers) +;; (puthash (car k) (list (car k)) openers)) +;; (unless (or (member (cdr k) non-closers) +;; (member (cdr k) closers)) +;; (push (cdr k) closers))) +;; prec2) +;; ;; Then collect the matching elements. +;; (while (not done) +;; (setq done t) +;; (maphash (lambda (k v) +;; (when (eq v '=) +;; (let ((aopeners (gethash (car k) openers)) +;; (dopeners (gethash (cdr k) openers)) +;; (new nil)) +;; (dolist (o aopeners) +;; (unless (member o dopeners) +;; (setq new t) +;; (push o dopeners))) +;; (when new +;; (setq done nil) +;; (puthash (cdr k) dopeners openers))))) +;; prec2)) +;; ;; Finally, dump the resulting table. +;; (let ((alist '())) +;; (maphash (lambda (k v) +;; (when (or include-inners (member k closers)) +;; (dolist (opener v) +;; (unless (equal opener k) +;; (push (cons opener k) alist))))) +;; openers) +;; alist))) + +(defun smie-bnf-closer-alist (bnf &optional no-inners) + ;; We can also build this closer-alist table from a prec2 table, + ;; but it takes more work, and the order is unpredictable, which + ;; is a problem for smie-close-block. + ;; More convenient would be to build it from a levels table since we + ;; always have this table (contrary to the BNF), but it has all the + ;; disadvantages of the prec2 case plus the disadvantage that the levels + ;; table has lost some info which would result in extra invalid pairs. + "Build a closer-alist from a BNF table. +The return value is in the same form as `smie-closer-alist'. +NO-INNERS if non-nil means that inner keywords will be excluded +from the table, e.g. the table will not include things like (\"if\" . \"else\")." + (let ((nts (mapcar #'car bnf)) ;non terminals. + (alist '())) + (dolist (nt bnf) + (dolist (rhs (cdr nt)) + (unless (or (< (length rhs) 2) (member (car rhs) nts)) + (if no-inners + (let ((last (car (last rhs)))) + (unless (member last nts) + (pushnew (cons (car rhs) last) alist :test #'equal))) + ;; Reverse so that the "real" closer gets there first, + ;; which is important for smie-close-block. + (dolist (term (reverse (cdr rhs))) + (unless (member term nts) + (pushnew (cons (car rhs) term) alist :test #'equal))))))) + (nreverse alist))) + +(defun smie-bnf-classify (bnf) + "Return a table classifying terminals. +Each terminal can either be an `opener', a `closer', or neither." + (let ((table (make-hash-table :test #'equal)) + (alist '())) + (dolist (category bnf) + (puthash (car category) 'neither table) ;Remove non-terminals. + (dolist (rhs (cdr category)) + (if (null (cdr rhs)) + (puthash (pop rhs) 'neither table) + (let ((first (pop rhs))) + (puthash first + (if (memq (gethash first table) '(nil opener)) + 'opener 'neither) + table)) + (while (cdr rhs) + (puthash (pop rhs) 'neither table)) ;Remove internals. + (let ((last (pop rhs))) + (puthash last + (if (memq (gethash last table) '(nil closer)) + 'closer 'neither) + table))))) + (maphash (lambda (tok v) + (when (memq v '(closer opener)) + (push (cons tok v) alist))) + table) + alist)) + +(defun smie-debug--prec2-cycle (csts) + "Return a cycle in CSTS, assuming there's one. +CSTS is a list of pairs representing arcs in a graph." + ;; A PATH is of the form (START . REST) where REST is a reverse + ;; list of nodes through which the path goes. + (let ((paths (mapcar (lambda (pair) (list (car pair) (cdr pair))) csts)) + (cycle nil)) + (while (null cycle) + (dolist (path (prog1 paths (setq paths nil))) + (dolist (cst csts) + (when (eq (car cst) (nth 1 path)) + (if (eq (cdr cst) (car path)) + (setq cycle path) + (push (cons (car path) (cons (cdr cst) (cdr path))) + paths)))))) + (cons (car cycle) (nreverse (cdr cycle))))) + +(defun smie-debug--describe-cycle (table cycle) + (let ((names + (mapcar (lambda (val) + (let ((res nil)) + (dolist (elem table) + (if (eq (cdr elem) val) + (push (concat "." (car elem)) res)) + (if (eq (cddr elem) val) + (push (concat (car elem) ".") res))) + (assert res) + res)) + cycle))) + (mapconcat + (lambda (elems) (mapconcat 'identity elems "=")) + (append names (list (car names))) + " < "))) + (defun smie-prec2-levels (prec2) ;; FIXME: Rather than only return an alist of precedence levels, we should ;; also extract other useful data from it: - ;; - matching sets of block openers&closers (which can otherwise become - ;; collapsed into a single equivalence class in smie-op-levels) for - ;; smie-close-block as well as to detect mismatches in smie-next-sexp - ;; or in blink-paren (as well as to do the blink-paren for inner - ;; keywords like the "in" of "let..in..end"). ;; - better default indentation rules (i.e. non-zero indentation after inner ;; keywords like the "in" of "let..in..end") for smie-indent-after-keyword. ;; Of course, maybe those things would be even better handled in the @@ -223,7 +389,7 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or `smie-bnf-precedence-table'." ;; For each operator, we create two "variables" (corresponding to ;; the left and right precedence level), which are represented by - ;; cons cells. Those are the vary cons cells that appear in the + ;; cons cells. Those are the very cons cells that appear in the ;; final `table'. The value of each "variable" is kept in the `car'. (let ((table ()) (csts ()) @@ -233,18 +399,19 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or ;; variables (aka "precedence levels"). These can be either ;; equality constraints (in `eqs') or `<' constraints (in `csts'). (maphash (lambda (k v) - (if (setq tmp (assoc (car k) table)) - (setq x (cddr tmp)) - (setq x (cons nil nil)) - (push (cons (car k) (cons nil x)) table)) - (if (setq tmp (assoc (cdr k) table)) - (setq y (cdr tmp)) - (setq y (cons nil (cons nil nil))) - (push (cons (cdr k) y) table)) - (ecase v - (= (push (cons x y) eqs)) - (< (push (cons x y) csts)) - (> (push (cons y x) csts)))) + (when (consp k) + (if (setq tmp (assoc (car k) table)) + (setq x (cddr tmp)) + (setq x (cons nil nil)) + (push (cons (car k) (cons nil x)) table)) + (if (setq tmp (assoc (cdr k) table)) + (setq y (cdr tmp)) + (setq y (cons nil (cons nil nil))) + (push (cons (cdr k) y) table)) + (ecase v + (= (push (cons x y) eqs)) + (< (push (cons x y) csts)) + (> (push (cons y x) csts))))) prec2) ;; First process the equality constraints. (let ((eqs eqs)) @@ -286,7 +453,9 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or (incf i)) (setq csts (delq cst csts)))) (unless progress - (error "Can't resolve the precedence table to precedence levels"))) + (error "Can't resolve the precedence cycle: %s" + (smie-debug--describe-cycle + table (smie-debug--prec2-cycle csts))))) (incf i 10)) ;; Propagate equalities back to their source. (dolist (eq (nreverse eqs)) @@ -294,16 +463,22 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or (setcar (car eq) (cadr eq))) ;; Finally, fill in the remaining vars (which only appeared on the ;; right side of the < constraints). - (dolist (x table) - ;; When both sides are nil, it means this operator binds very - ;; very tight, but it's still just an operator, so we give it - ;; the highest precedence. - ;; OTOH if only one side is nil, it usually means it's like an - ;; open-paren, which is very important for indentation purposes, - ;; so we keep it nil, to make it easier to recognize. - (unless (or (nth 1 x) (nth 2 x)) - (setf (nth 1 x) i) - (setf (nth 2 x) i)))) + (let ((classification-table (gethash :smie-open/close-alist prec2))) + (dolist (x table) + ;; When both sides are nil, it means this operator binds very + ;; very tight, but it's still just an operator, so we give it + ;; the highest precedence. + ;; OTOH if only one side is nil, it usually means it's like an + ;; open-paren, which is very important for indentation purposes, + ;; so we keep it nil if so, to make it easier to recognize. + (unless (or (nth 1 x) + (eq 'opener (cdr (assoc (car x) classification-table)))) + (setf (nth 1 x) i) + (incf i)) ;See other (incf i) above. + (unless (or (nth 2 x) + (eq 'closer (cdr (assoc (car x) classification-table)))) + (setf (nth 2 x) i) + (incf i))))) ;See other (incf i) above. table)) ;;; Parsing using a precedence level table. @@ -349,7 +524,7 @@ it should move backward to the beginning of the previous token.") (skip-syntax-forward "w_'")) (point)))) -(defun smie-associative-p (toklevels) +(defun smie--associative-p (toklevels) ;; in "a + b + c" we want to stop at each +, but in ;; "if a then b elsif c then d else c" we don't want to stop at each keyword. ;; To distinguish the two cases, we made smie-prec2-levels choose @@ -434,13 +609,13 @@ Possible return values: ;; If the new operator is not the last in the BNF rule, ;; ans is not associative, it's one of the inner operators ;; (like the "in" in "let .. in .. end"), so keep looking. - ((not (smie-associative-p toklevels)) + ((not (smie--associative-p toklevels)) (push toklevels levels)) ;; The new operator is associative. Two cases: ;; - it's really just an associative operator (like + or ;) ;; in which case we should have stopped right before. ((and lastlevels - (smie-associative-p (car lastlevels))) + (smie--associative-p (car lastlevels))) (throw 'return (prog1 (list (or (car toklevels) t) (point) token) (goto-char pos)))) @@ -560,6 +735,115 @@ Possible return values: (indent-according-to-mode) (reindent-then-newline-and-indent)))) +(defun smie-down-list (&optional arg) + "Move forward down one level paren-like blocks. Like `down-list'. +With argument ARG, do this that many times. +A negative argument means move backward but still go down a level. +This command assumes point is not in a string or comment." + (interactive "p") + (let ((start (point)) + (inc (if (< arg 0) -1 1)) + (offset (if (< arg 0) 1 0)) + (next-token (if (< arg 0) + smie-backward-token-function + smie-forward-token-function))) + (while (/= arg 0) + (setq arg (- arg inc)) + (while + (let* ((pos (point)) + (token (funcall next-token)) + (levels (assoc token smie-op-levels))) + (cond + ((zerop (length token)) + (if (if (< inc 0) (looking-back "\\s(\\|\\s)" (1- (point))) + (looking-at "\\s(\\|\\s)")) + ;; Go back to `start' in case of an error. This presumes + ;; none of the token we've found until now include a ( or ). + (progn (goto-char start) (down-list inc) nil) + (forward-sexp inc) + (/= (point) pos))) + ((and levels (null (nth (+ 1 offset) levels))) nil) + ((and levels (null (nth (- 2 offset) levels))) + (let ((end (point))) + (goto-char start) + (signal 'scan-error + (list "Containing expression ends prematurely" + pos end)))) + (t))))))) + +(defvar smie-blink-matching-triggers '(?\s ?\n) + "Chars which might trigger `blink-matching-open'. +These can include the final chars of end-tokens, or chars that are +typically inserted right after an end token. +I.e. a good choice can be: + (delete-dups + (mapcar (lambda (kw) (aref (cdr kw) (1- (length (cdr kw))))) + smie-closer-alist))") + +(defcustom smie-blink-matching-inners t + "Whether SMIE should blink to matching opener for inner keywords. +If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"." + :type 'boolean) + +(defun smie-blink-matching-check (start end) + (save-excursion + (goto-char end) + (let ((ender (funcall smie-backward-token-function))) + (cond + ((not (and ender (rassoc ender smie-closer-alist))) + ;; This not is one of the begin..end we know how to check. + (blink-matching-check-mismatch start end)) + ((not start) t) + ((eq t (car (rassoc ender smie-closer-alist))) nil) + (t + (goto-char start) + (let ((starter (funcall smie-forward-token-function))) + (not (member (cons starter ender) smie-closer-alist)))))))) + +(defun smie-blink-matching-open () + "Blink the matching opener when applicable. +This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'." + (when (and blink-matching-paren + smie-closer-alist ; Optimization. + (eq (char-before) last-command-event) ; Sanity check. + (memq last-command-event smie-blink-matching-triggers) + (not (nth 8 (syntax-ppss)))) + (save-excursion + (let ((pos (point)) + (token (funcall smie-backward-token-function))) + (when (and (eq (point) (1- pos)) + (= 1 (length token)) + (not (rassoc token smie-closer-alist))) + ;; The trigger char is itself a token but is not one of the + ;; closers (e.g. ?\; in Octave mode), so go back to the + ;; previous token. + (setq pos (point)) + (setq token (save-excursion + (funcall smie-backward-token-function)))) + (when (rassoc token smie-closer-alist) + ;; We're after a close token. Let's still make sure we + ;; didn't skip a comment to find that token. + (funcall smie-forward-token-function) + (when (and (save-excursion + ;; Trigger can be SPC, or reindent. + (skip-chars-forward " \n\t") + (>= (point) pos)) + ;; If token ends with a trigger char, so don't blink for + ;; anything else than this trigger char, lest we'd blink + ;; both when inserting the trigger char and when + ;; inserting a subsequent trigger char like SPC. + (or (eq (point) pos) + (not (memq (char-before) + smie-blink-matching-triggers))) + (or smie-blink-matching-inners + (null (nth 2 (assoc token smie-op-levels))))) + ;; The major mode might set blink-matching-check-function + ;; buffer-locally so that interactive calls to + ;; blink-matching-open work right, but let's not presume + ;; that's the case. + (let ((blink-matching-check-function #'smie-blink-matching-check)) + (blink-matching-open)))))))) + ;;; The indentation engine. (defcustom smie-indent-basic 4 @@ -593,22 +877,23 @@ OFFSET-RULES is a list of elements which can each either be: \(:bolp . OFFSET-RULES) If TOK is first on a line, use OFFSET-RULES. OFFSET the offset to use. -PARENT can be either the name of the parent or `open' to mean any parent -which acts as an open-paren (i.e. has a nil left-precedence). +PARENT can be either the name of the parent or a list of such names. OFFSET can be of the form: `point' align with the token. `parent' align with the parent. NUMBER offset by NUMBER. \(+ OFFSETS...) use the sum of OFFSETS. +VARIABLE use the value of VARIABLE as offset. The precise meaning of `point' depends on various details: it can either mean the position of the token we're indenting, or the position of its parent, or the position right after its parent. -A nil offset for indentation after a token defaults to `smie-indent-basic'.") +A nil offset for indentation after an opening token defaults +to `smie-indent-basic'.") -(defun smie-indent-hanging-p () +(defun smie-indent--hanging-p () ;; A hanging keyword is one that's at the end of a line except it's not at ;; the beginning of a line. (and (save-excursion @@ -617,19 +902,19 @@ A nil offset for indentation after a token defaults to `smie-indent-basic'.") (forward-char 1)) (skip-chars-forward " \t") (eolp)) - (not (smie-bolp)))) + (not (smie-indent--bolp)))) -(defun smie-bolp () +(defun smie-indent--bolp () (save-excursion (skip-chars-backward " \t") (bolp))) -(defun smie-indent-offset (elem) +(defun smie-indent--offset (elem) (or (cdr (assq elem smie-indent-rules)) (cdr (assq t smie-indent-rules)) smie-indent-basic)) (defvar smie-indent-debug-log) -(defun smie-indent-offset-rule (tokinfo &optional after parent) +(defun smie-indent--offset-rule (tokinfo &optional after parent) "Apply the OFFSET-RULES in TOKINFO. Point is expected to be right in front of the token corresponding to TOKINFO. If computing the indentation after the token, then AFTER is the position @@ -644,10 +929,10 @@ PARENT if non-nil should be the parent info returned by `smie-backward-sexp'." ((not (consp rule)) (setq offset rule)) ((eq (car rule) '+) (setq offset rule)) ((eq (car rule) :hanging) - (when (smie-indent-hanging-p) + (when (smie-indent--hanging-p) (setq rules (cdr rule)))) ((eq (car rule) :bolp) - (when (smie-bolp) + (when (smie-indent--bolp) (setq rules (cdr rule)))) ((eq (car rule) :eolp) (unless after @@ -674,8 +959,9 @@ PARENT if non-nil should be the parent info returned by `smie-backward-sexp'." (save-excursion (if after (goto-char after)) (setq parent (smie-backward-sexp 'halfsexp)))) - (when (or (equal (nth 2 parent) (cadr rule)) - (and (eq (cadr rule) 'open) (null (car parent)))) + (when (if (listp (cadr rule)) + (member (nth 2 parent) (cadr rule)) + (equal (nth 2 parent) (cadr rule))) (setq rules (cddr rule)))) (t (error "Unknown rule %s for indentation of %s" rule (car tokinfo)))))) @@ -686,13 +972,13 @@ PARENT if non-nil should be the parent info returned by `smie-backward-sexp'." (push (list (point) offset tokinfo) smie-indent-debug-log)) offset)) -(defun smie-indent-column (offset &optional base parent virtual-point) +(defun smie-indent--column (offset &optional base parent virtual-point) "Compute the actual column to use for a given OFFSET. BASE is the base position to use, and PARENT is the parent info, if any. If VIRTUAL-POINT is non-nil, then `point' is virtual." (cond ((eq (car-safe offset) '+) - (apply '+ (mapcar (lambda (offset) (smie-indent-column offset nil parent)) + (apply '+ (mapcar (lambda (offset) (smie-indent--column offset nil parent)) (cdr offset)))) ((integerp offset) (+ offset @@ -726,6 +1012,8 @@ If VIRTUAL-POINT is non-nil, then `point' is virtual." (if (consp parent) (goto-char (cadr parent))) (smie-indent-virtual)) ((eq offset nil) nil) + ((and (symbolp offset) (boundp 'offset)) + (smie-indent--column (symbol-value offset) base parent virtual-point)) (t (error "Unknown indentation offset %s" offset)))) (defun smie-indent-forward-token () @@ -758,11 +1046,11 @@ This is used when we're not trying to indent point but just need to compute the column at which point should be indented in order to figure out the indentation of some other (further down) point." ;; Trust pre-existing indentation on other lines. - (if (smie-bolp) (current-column) (smie-indent-calculate))) + (if (smie-indent--bolp) (current-column) (smie-indent-calculate))) (defun smie-indent-fixindent () ;; Obey the `fixindent' special comment. - (and (smie-bolp) + (and (smie-indent--bolp) (save-excursion (comment-normalize-vars) (re-search-forward (concat comment-start-skip @@ -802,14 +1090,14 @@ in order to figure out the indentation of some other (further down) point." (save-excursion (goto-char pos) ;; Different cases: - ;; - smie-bolp: "indent according to others". + ;; - smie-indent--bolp: "indent according to others". ;; - common hanging: "indent according to others". ;; - SML-let hanging: "indent like parent". ;; - if-after-else: "indent-like parent". ;; - middle-of-line: "trust current position". (cond ((null (cdr toklevels)) nil) ;Not a keyword. - ((smie-bolp) + ((smie-indent--bolp) ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). nil) @@ -821,8 +1109,8 @@ in order to figure out the indentation of some other (further down) point." ;; By default use point unless we're hanging. `((:before . ,token) (:hanging nil) point))) ;; (after (prog1 (point) (goto-char pos))) - (offset (smie-indent-offset-rule tokinfo))) - (smie-indent-column offset))))) + (offset (smie-indent--offset-rule tokinfo))) + (smie-indent--column offset))))) ;; FIXME: This still looks too much like black magic!! ;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we @@ -838,7 +1126,7 @@ in order to figure out the indentation of some other (further down) point." point))) (offset (save-excursion (goto-char pos) - (smie-indent-offset-rule tokinfo nil parent)))) + (smie-indent--offset-rule tokinfo nil parent)))) ;; Different behaviors: ;; - align with parent. ;; - parent + offset. @@ -863,10 +1151,10 @@ in order to figure out the indentation of some other (further down) point." nil) ((eq (car parent) (car toklevels)) ;; We bumped into a same-level operator. align with it. - (if (and (smie-bolp) (/= (point) pos) + (if (and (smie-indent--bolp) (/= (point) pos) (save-excursion (goto-char (goto-char (cadr parent))) - (not (smie-bolp))) + (not (smie-indent--bolp))) ;; Check the offset of `token' rather then its parent ;; because its parent may have used a special rule. E.g. ;; function foo; @@ -903,7 +1191,7 @@ in order to figure out the indentation of some other (further down) point." ;; So as to align with the earliest appropriate place. (smie-indent-virtual))) (tokinfo - (if (and (= (point) pos) (smie-bolp) + (if (and (= (point) pos) (smie-indent--bolp) (or (eq offset 'point) (and (consp offset) (memq 'point offset)))) ;; Since we started at BOL, we're not computing a virtual @@ -911,7 +1199,7 @@ in order to figure out the indentation of some other (further down) point." ;; we can't use `current-column' which would cause ;; indentation to depend on itself. nil - (smie-indent-column offset 'parent parent + (smie-indent--column offset 'parent parent ;; If we're still at pos, indent-virtual ;; will inf-loop. (unless (= (point) pos) 'virtual)))))))))) @@ -921,8 +1209,12 @@ in order to figure out the indentation of some other (further down) point." ;; Don't do it for virtual indentations. We should normally never be "in ;; front of a comment" when doing virtual-indentation anyway. And if we are ;; (as can happen in octave-mode), moving forward can lead to inf-loops. - (and (smie-bolp) - (looking-at comment-start-skip) + (and (smie-indent--bolp) + (let ((pos (point))) + (save-excursion + (beginning-of-line) + (and (re-search-forward comment-start-skip (line-end-position) t) + (eq pos (or (match-end 1) (match-beginning 0)))))) (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") @@ -943,6 +1235,20 @@ in order to figure out the indentation of some other (further down) point." (if (looking-at (regexp-quote continue)) (current-column)))))))) +(defun smie-indent-comment-close () + (and (boundp 'comment-end-skip) + comment-end-skip + (not (looking-at " \t*$")) ;Not just a \n comment-closer. + (looking-at comment-end-skip) + (nth 4 (syntax-ppss)) + (save-excursion + (goto-char (nth 8 (syntax-ppss))) + (current-column)))) + +(defun smie-indent-comment-inside () + (and (nth 4 (syntax-ppss)) + 'noindent)) + (defun smie-indent-after-keyword () ;; Indentation right after a special keyword. (save-excursion @@ -962,13 +1268,13 @@ in order to figure out the indentation of some other (further down) point." ;; Using the BNF syntax, we could come up with better ;; defaults, but we only have the precedence levels here. (setq tokinfo (list tok 'default-rule - (if (cadr toklevel) 0 (smie-indent-offset t))))) + (if (cadr toklevel) 0 (smie-indent--offset t))))) (let ((offset - (or (smie-indent-offset-rule tokinfo pos) - (smie-indent-offset t)))) + (or (smie-indent--offset-rule tokinfo pos) + (smie-indent--offset t)))) (let ((before (point))) (goto-char pos) - (smie-indent-column offset before))))))) + (smie-indent--column offset before))))))) (defun smie-indent-exps () ;; Indentation of sequences of simple expressions without @@ -991,7 +1297,7 @@ in order to figure out the indentation of some other (further down) point." arg) (while (and (null (car (smie-backward-sexp))) (push (point) positions) - (not (smie-bolp)))) + (not (smie-indent--bolp)))) (save-excursion ;; Figure out if the atom we just skipped is an argument rather ;; than a function. @@ -1016,16 +1322,18 @@ in order to figure out the indentation of some other (further down) point." (positions ;; We're the first arg. (goto-char (car positions)) - (+ (smie-indent-offset 'args) + ;; FIXME: Use smie-indent--column. + (+ (smie-indent--offset 'args) ;; We used to use (smie-indent-virtual), but that ;; doesn't seem right since it might then indent args less than ;; the function itself. (current-column))))))) (defvar smie-indent-functions - '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment - smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword - smie-indent-exps) + '(smie-indent-fixindent smie-indent-bob smie-indent-close + smie-indent-comment smie-indent-comment-continue smie-indent-comment-close + smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword + smie-indent-exps) "Functions to compute the indentation. Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 5cc89596ef5..b85399263d0 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -34,7 +34,6 @@ ;; - do something about the case where the syntax-table is changed. ;; This typically happens with tex-mode and its `$' operator. -;; - move font-lock-syntactic-keywords in here. Then again, maybe not. ;; - new functions `syntax-state', ... to replace uses of parse-partial-state ;; with something higher-level (similar to syntax-ppss-context). ;; - interaction with mmm-mode. @@ -47,6 +46,281 @@ (defvar font-lock-beginning-of-syntax-function) +;;; Applying syntax-table properties where needed. + +(defvar syntax-propertize-function nil + ;; Rather than a -functions hook, this is a -function because it's easier + ;; to do a single scan than several scans: with multiple scans, one cannot + ;; assume that the text before point has been propertized, so syntax-ppss + ;; gives unreliable results (and stores them in its cache to boot, so we'd + ;; have to flush that cache between each function, and we couldn't use + ;; syntax-ppss-flush-cache since that would not only flush the cache but also + ;; reset syntax-propertize--done which should not be done in this case). + "Mode-specific function to apply the syntax-table properties. +Called with 2 arguments: START and END. +This function can call `syntax-ppss' on any position before END, but it +should not call `syntax-ppss-flush-cache', which means that it should not +call `syntax-ppss' on some position and later modify the buffer on some +earlier position.") + +(defvar syntax-propertize-chunk-size 500) + +(defvar syntax-propertize-extend-region-functions + '(syntax-propertize-wholelines) + "Special hook run just before proceeding to propertize a region. +This is used to allow major modes to help `syntax-propertize' find safe buffer +positions as beginning and end of the propertized region. Its most common use +is to solve the problem of /identification/ of multiline elements by providing +a function that tries to find such elements and move the boundaries such that +they do not fall in the middle of one. +Each function is called with two arguments (START and END) and it should return +either a cons (NEW-START . NEW-END) or nil if no adjustment should be made. +These functions are run in turn repeatedly until they all return nil. +Put first the functions more likely to cause a change and cheaper to compute.") +;; Mark it as a special hook which doesn't use any global setting +;; (i.e. doesn't obey the element t in the buffer-local value). +(make-variable-buffer-local 'syntax-propertize-extend-region-functions) + +(defun syntax-propertize-wholelines (start end) + (goto-char start) + (cons (line-beginning-position) + (progn (goto-char end) + (if (bolp) (point) (line-beginning-position 2))))) + +(defun syntax-propertize-multiline (beg end) + "Let `syntax-propertize' pay attention to the syntax-multiline property." + (when (and (> beg (point-min)) + (get-text-property (1- beg) 'syntax-multiline)) + (setq beg (or (previous-single-property-change beg 'syntax-multiline) + (point-min)))) + ;; + (when (get-text-property end 'font-lock-multiline) + (setq end (or (text-property-any end (point-max) + 'syntax-multiline nil) + (point-max)))) + (cons beg end)) + +(defvar syntax-propertize--done -1 + "Position upto which syntax-table properties have been set.") +(make-variable-buffer-local 'syntax-propertize--done) + +(defun syntax-propertize--shift-groups (re n) + (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + +(defmacro syntax-propertize-precompile-rules (&rest rules) + "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. +The arg RULES can be of the same form as in `syntax-propertize-rules'. +The return value is an object that can be passed as a rule to +`syntax-propertize-rules'. +I.e. this is useful only when you want to share rules among several +syntax-propertize-functions." + (declare (debug syntax-propertize-rules)) + ;; Precompile? Yeah, right! + ;; Seriously, tho, this is a macro for 2 reasons: + ;; - we could indeed do some pre-compilation at some point in the future, + ;; e.g. fi/when we switch to a DFA-based implementation of + ;; syntax-propertize-rules. + ;; - this lets Edebug properly annotate the expressions inside RULES. + `',rules) + +(defmacro syntax-propertize-rules (&rest rules) + "Make a function that applies RULES for use in `syntax-propertize-function'. +The function will scan the buffer, applying the rules where they match. +The buffer is scanned a single time, like \"lex\" would, rather than once +per rule. + +Each RULE can be a symbol, in which case that symbol's value should be, +at macro-expansion time, a precompiled set of rules, as returned +by `syntax-propertize-precompile-rules'. + +Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where +REGEXP is an expression (evaluated at time of macro-expansion) that returns +a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to +apply the property SYNTAX to the chars matched by the subgroup NUMBER +of the regular expression, if NUMBER did match. +SYNTAX is an expression that returns a value to apply as `syntax-table' +property. Some expressions are handled specially: +- if SYNTAX is a string, then it is converted with `string-to-syntax'; +- if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP + will be applied to the buffer before running EXPS and if EXP is a string it + is also converted with `string-to-syntax'. +The SYNTAX expression is responsible to save the `match-data' if needed +for subsequent HIGHLIGHTs. +Also SYNTAX is free to move point, in which case RULES may not be applied to +some parts of the text or may be applied several times to other parts. + +Note: back-references in REGEXPs do not work." + (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. + (form &rest + (numberp + [&or stringp ;FIXME: Use &wrap + ("prog1" [&or stringp def-form] def-body) + def-form]))))) + (let ((newrules nil)) + (while rules + (if (symbolp (car rules)) + (setq rules (append (symbol-value (pop rules)) rules)) + (push (pop rules) newrules))) + (setq rules (nreverse newrules))) + (let* ((offset 0) + (branches '()) + ;; We'd like to use a real DFA-based lexer, usually, but since Emacs + ;; doesn't have one yet, we fallback on building one large regexp + ;; and use groups to determine which branch of the regexp matched. + (re + (mapconcat + (lambda (rule) + (let* ((orig-re (eval (car rule))) + (re orig-re)) + (when (and (assq 0 rule) (cdr rules)) + ;; If there's more than 1 rule, and the rule want to apply + ;; highlight to match 0, create an extra group to be able to + ;; tell when *this* match 0 has succeeded. + (incf offset) + (setq re (concat "\\(" re "\\)"))) + (setq re (syntax-propertize--shift-groups re offset)) + (let ((code '()) + (condition + (cond + ((assq 0 rule) (if (zerop offset) t + `(match-beginning ,offset))) + ((null (cddr rule)) + `(match-beginning ,(+ offset (car (cadr rule))))) + (t + `(or ,@(mapcar + (lambda (case) + `(match-beginning ,(+ offset (car case)))) + (cdr rule)))))) + (nocode t) + (offset offset)) + ;; If some of the subgroup rules include Elisp code, then we + ;; need to set the match-data so it's consistent with what the + ;; code expects. If not, then we can simply use shifted + ;; offset in our own code. + (unless (zerop offset) + (dolist (case (cdr rule)) + (unless (stringp (cadr case)) + (setq nocode nil))) + (unless nocode + (push `(let ((md (match-data 'ints))) + ;; Keep match 0 as is, but shift everything else. + (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md)) + (set-match-data md)) + code) + (setq offset 0))) + ;; Now construct the code for each subgroup rules. + (dolist (case (cdr rule)) + (assert (null (cddr case))) + (let* ((gn (+ offset (car case))) + (action (nth 1 case)) + (thiscode + (cond + ((stringp action) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax action)))) + ((eq (car-safe action) 'ignore) + (cdr action)) + ((eq (car-safe action) 'prog1) + (if (stringp (nth 1 action)) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax (nth 1 action))) + ,@(nthcdr 2 action)) + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,(nth 1 action))) + (if syntax + (put-text-property + mb me 'syntax-table syntax)) + ,@(nthcdr 2 action))))) + (t + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,action)) + (if syntax + (put-text-property + mb me 'syntax-table syntax)))))))) + + (if (or (not (cddr rule)) (zerop gn)) + (setq code (nconc (nreverse thiscode) code)) + (push `(if (match-beginning ,gn) + ;; Try and generate clean code with no + ;; extraneous progn. + ,(if (null (cdr thiscode)) + (car thiscode) + `(progn ,@thiscode))) + code)))) + (push (cons condition (nreverse code)) + branches)) + (incf offset (regexp-opt-depth orig-re)) + re)) + rules + "\\|"))) + `(lambda (start end) + (goto-char start) + (while (and (< (point) end) + (re-search-forward ,re end t)) + (cond ,@(nreverse branches)))))) + +(defun syntax-propertize-via-font-lock (keywords) + "Propertize for syntax in START..END using font-lock syntax. +KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. +The return value is a function suitable for `syntax-propertize-function'." + (lexical-let ((keywords keywords)) + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords)))))) + +(defun syntax-propertize (pos) + "Ensure that syntax-table properties are set upto POS." + (when (and syntax-propertize-function + (< syntax-propertize--done pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (let* ((start (max syntax-propertize--done (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end))) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + (funcall syntax-propertize-function start end)))))) + +;;; Incrementally compute and memoize parser state. + (defsubst syntax-ppss-depth (ppss) (nth 0 ppss)) @@ -92,6 +366,8 @@ point (where the PPSS is equivalent to nil).") (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." + ;; Set syntax-propertize to refontify anything past beg. + (setq syntax-propertize--done (min beg syntax-propertize--done)) ;; Flush invalid cache entries. (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg)) (setq syntax-ppss-cache (cdr syntax-ppss-cache))) @@ -128,6 +404,7 @@ the 2nd and 6th values of the returned state cannot be relied upon. Point is at POS when this function returns." ;; Default values. (unless pos (setq pos (point))) + (syntax-propertize pos) ;; (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last)) @@ -209,7 +486,8 @@ Point is at POS when this function returns." (funcall syntax-begin-function) ;; Make sure it's better. (> (point) pt-best)) - ;; Simple sanity check. + ;; Simple sanity checks. + (< (point) pos) ; backward-paragraph can fail here. (not (memq (get-text-property (point) 'face) '(font-lock-string-face font-lock-doc-face font-lock-comment-face)))) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index cf5e79d2a26..8df70f4d979 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -6,6 +6,7 @@ ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: spreadsheet lisp utility +;; Package: testcover ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index b300ee6dcef..47f931bf9d3 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -5,6 +5,7 @@ ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> ;; Keywords: safety lisp utility +;; Package: testcover ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 94f39940b66..b12d9068676 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -4,6 +4,7 @@ ;; 2009, 2010 Free Software Foundation, Inc. ;; Maintainer: FSF +;; Package: emacs ;; This file is part of GNU Emacs. @@ -92,31 +93,20 @@ fire each time Emacs is idle for that many seconds." More precisely, the next value, after TIME, that is an integral multiple of SECS seconds since the epoch. SECS may be a fraction." (let ((time-base (ash 1 16))) - (if (fboundp 'atan) - ;; Use floating point, taking care to not lose precision. - (let* ((float-time-base (float time-base)) - (million 1000000.0) - (time-usec (+ (* million - (+ (* float-time-base (nth 0 time)) - (nth 1 time))) - (nth 2 time))) - (secs-usec (* million secs)) - (mod-usec (mod time-usec secs-usec)) - (next-usec (+ (- time-usec mod-usec) secs-usec)) - (time-base-million (* float-time-base million))) - (list (floor next-usec time-base-million) - (floor (mod next-usec time-base-million) million) - (floor (mod next-usec million)))) - ;; Floating point is not supported. - ;; Use integer arithmetic, avoiding overflow if possible. - (let* ((mod-sec (mod (+ (* (mod time-base secs) - (mod (nth 0 time) secs)) - (nth 1 time)) - secs)) - (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) - (list (+ (nth 0 time) (floor next-1-sec time-base)) - (mod next-1-sec time-base) - 0))))) + ;; Use floating point, taking care to not lose precision. + (let* ((float-time-base (float time-base)) + (million 1000000.0) + (time-usec (+ (* million + (+ (* float-time-base (nth 0 time)) + (nth 1 time))) + (nth 2 time))) + (secs-usec (* million secs)) + (mod-usec (mod time-usec secs-usec)) + (next-usec (+ (- time-usec mod-usec) secs-usec)) + (time-base-million (* float-time-base million))) + (list (floor next-usec time-base-million) + (floor (mod next-usec time-base-million) million) + (floor (mod next-usec million)))))) (defun timer-relative-time (time secs &optional usecs) "Advance TIME by SECS seconds and optionally USECS microseconds. @@ -442,8 +432,6 @@ This function returns a timer object which you can use in `cancel-timer'." "This is the timer function used for the timer made by `with-timeout'." (throw tag 'timeout)) -(put 'with-timeout 'lisp-indent-function 1) - (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") @@ -455,6 +443,7 @@ event (such as keyboard input, input from subprocesses, or a certain time); if the program loops without waiting in any way, the timeout will not be detected. \n(fn (SECONDS TIMEOUT-FORMS...) BODY)" + (declare (indent 1)) (let ((seconds (car list)) (timeout-forms (cdr list))) `(let ((with-timeout-tag (cons nil nil)) @@ -543,5 +532,4 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (provide 'timer) -;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 ;;; timer.el ends here diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 851a1f7652b..a62f8de4010 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -101,15 +101,13 @@ in the parse.") (dolist (x '(;;Special forms and catch if or prog1 prog2 progn while unwind-protect ;;Safe subrs that have some side-effects - ding error message minibuffer-message random read-minibuffer - signal sleep-for string-match throw y-or-n-p yes-or-no-p + ding error random signal sleep-for string-match throw ;;Defsubst functions from subr.el caar cadr cdar cddr ;;Macros from subr.el - save-match-data unless when with-temp-message + save-match-data unless when ;;Functions from subr.el that have side effects - read-passwd split-string replace-regexp-in-string - play-sound-file)) + split-string replace-regexp-in-string play-sound-file)) (put x 'safe-function t)) ;;;###autoload diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 4adb93a852d..ba8c8ffc831 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -119,9 +119,9 @@ See also `warning-suppress-log-types'." :type '(repeat (repeat symbol)) :version "22.1") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-prefix-function nil "Function to generate warning prefixes. @@ -132,9 +132,9 @@ The warnings buffer is current when this function is called and the function can insert text in it. This text becomes the beginning of the warning.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-series nil "Non-nil means treat multiple `display-warning' calls as a series. @@ -146,16 +146,16 @@ A symbol with a function definition is like t, except also call that function before the next warning.") (put 'warning-series 'risky-local-variable t) -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-fill-prefix nil "Non-nil means fill each warning text using this string as `fill-prefix'.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-type-format (purecopy " (%s)") "Format for displaying the warning type in the warning message. @@ -241,6 +241,8 @@ See also `warning-series', `warning-prefix-function' and (with-current-buffer buffer ;; If we created the buffer, disable undo. (unless old + (special-mode) + (setq buffer-read-only t) (setq buffer-undo-list t)) (goto-char (point-max)) (when (and warning-series (symbolp warning-series)) @@ -248,6 +250,7 @@ See also `warning-series', `warning-prefix-function' and (prog1 (point-marker) (unless (eq warning-series t) (funcall warning-series))))) + (let ((inhibit-read-only t)) (unless (bolp) (newline)) (setq start (point)) @@ -262,7 +265,7 @@ See also `warning-series', `warning-prefix-function' and (let ((fill-prefix warning-fill-prefix) (fill-column 78)) (fill-region start (point)))) - (setq end (point)) + (setq end (point))) (when (and (markerp warning-series) (eq (marker-buffer warning-series) buffer)) (goto-char warning-series))) |