summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/authors.el9
-rw-r--r--lisp/emacs-lisp/autoload.el15
-rw-r--r--lisp/emacs-lisp/byte-opt.el104
-rw-r--r--lisp/emacs-lisp/bytecomp.el116
-rw-r--r--lisp/emacs-lisp/chart.el9
-rw-r--r--lisp/emacs-lisp/checkdoc.el338
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el2
-rw-r--r--lisp/emacs-lisp/cl-macs.el241
-rw-r--r--lisp/emacs-lisp/easy-mmode.el5
-rw-r--r--lisp/emacs-lisp/edebug.el9
-rw-r--r--lisp/emacs-lisp/eieio-comp.el19
-rw-r--r--lisp/emacs-lisp/elint.el46
-rw-r--r--lisp/emacs-lisp/find-func.el12
-rw-r--r--lisp/emacs-lisp/float-sup.el18
-rw-r--r--lisp/emacs-lisp/lisp-mode.el8
-rw-r--r--lisp/emacs-lisp/package.el418
-rw-r--r--lisp/emacs-lisp/pcase.el377
-rw-r--r--lisp/emacs-lisp/regexp-opt.el13
-rw-r--r--lisp/emacs-lisp/smie.el916
-rw-r--r--lisp/emacs-lisp/timer.el40
-rw-r--r--lisp/emacs-lisp/unsafep.el8
21 files changed, 1504 insertions, 1219 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 248a2cf1312..ae490550021 100644
--- a/lisp/emacs-lisp/authors.el
+++ b/lisp/emacs-lisp/authors.el
@@ -268,6 +268,7 @@ listed.")
"CODINGS" "CHARSETS"
"calc/INSTALL" "calc/Makefile"
"vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/
+ "emacsver.texi.in"
;; MH-E stuff not in Emacs:
"import-emacs" "release-utils"
;; Erc stuff not in Emacs:
@@ -507,10 +508,11 @@ Changes to files in this list are not listed.")
"ymakefile"
"permute-index" "index.perm"
"ibmrs6000.inp"
- "b2m.c"
+ "b2m.c" "b2m.1" "b2m.pl"
+ "emacs.bash" "emacs.csh" "ms-kermit"
"emacs.ico"
"emacs21.ico"
- "LPF" "LEDIT" "OTHER.EMACSES"
+ "BABYL" "LPF" "LEDIT" "OTHER.EMACSES"
"emacs16_mac.png" "emacs24_mac.png"
"emacs256_mac.png" "emacs32_mac.png"
"emacs48_mac.png" "emacs512_mac.png"
@@ -585,12 +587,15 @@ in the repository.")
("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" )
("texi/url.txi" . "url.texi")
("edt-user.doc" . "edt.texi")
+ ("DEV-NOTES" . "nextstep")
;; Moved to different directories.
("ctags.1" . "ctags.1")
("etags.1" . "etags.1")
("emacs.1" . "emacs.1")
("emacsclient.1" . "emacsclient.1")
("icons/emacs21.ico" . "emacs21.ico")
+ ;; Moved from admin/nt/ to nt/.
+ ("nt/README.W32" . "README.W32")
)
"Alist of files which have been renamed during their lifetime.
Elements are (OLDNAME . NEWNAME).")
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 30c384aff91..4dd1a118ebd 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -575,8 +575,8 @@ removes any prior now out-of-date autoload entries."
(autoload-ensure-default-file (autoload-generated-file)))
;; This is to make generated-autoload-file have Unix EOLs, so
;; that it is portable to all platforms.
- (unless (zerop (coding-system-eol-type buffer-file-coding-system))
- (set-buffer-file-coding-system 'unix))
+ (or (eq 0 (coding-system-eol-type buffer-file-coding-system))
+ (set-buffer-file-coding-system 'unix))
(or (> (buffer-size) 0)
(error "Autoloads file %s lacks boilerplate" buffer-file-name))
(or (file-writable-p buffer-file-name)
@@ -778,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/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 4a073a8e2e9..24b762c9cb7 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1317,36 +1317,39 @@
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset
- ;; OP, PTR and BYTES are used and set dynamically
- (defvar op)
- (defvar ptr)
- (defvar bytes)
- (cond ((< op byte-nth)
- (let ((tem (logand op 7)))
- (setq op (logand op 248))
+ ;; Used and set dynamically in byte-decompile-bytecode-1.
+ (defvar bytedecomp-op)
+ (defvar bytedecomp-ptr)
+ (defvar bytedecomp-bytes)
+ (cond ((< bytedecomp-op byte-nth)
+ (let ((tem (logand bytedecomp-op 7)))
+ (setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))
+ ;; Offset in next byte.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (aref bytedecomp-bytes bytedecomp-ptr))
((eq tem 7)
- (setq ptr (1+ ptr)) ;offset in next 2 bytes
- (+ (aref bytes ptr)
- (progn (setq ptr (1+ ptr))
- (lsh (aref bytes ptr) 8))))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(t tem)))) ;offset was in opcode
- ((>= op byte-constant)
- (prog1 (- op byte-constant) ;offset in opcode
- (setq op byte-constant)))
- ((or (and (>= op byte-constant2)
- (<= op byte-goto-if-not-nil-else-pop))
- (= op byte-stack-set2))
- (setq ptr (1+ ptr)) ;offset in next 2 bytes
- (+ (aref bytes ptr)
- (progn (setq ptr (1+ ptr))
- (lsh (aref bytes ptr) 8))))
- ((and (>= op byte-listN)
- (<= op byte-discardN))
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))))
+ ((>= bytedecomp-op byte-constant)
+ (prog1 (- bytedecomp-op byte-constant) ;offset in opcode
+ (setq bytedecomp-op byte-constant)))
+ ((or (and (>= bytedecomp-op byte-constant2)
+ (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
+ (= bytedecomp-op byte-stack-set2))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
+ ((and (>= bytedecomp-op byte-listN)
+ (<= bytedecomp-op byte-discardN))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
+ (aref bytedecomp-bytes bytedecomp-ptr))))
;; This de-compiler is used for inline expansion of compiled functions,
@@ -1369,19 +1372,20 @@
;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
;; In that case, we put a pc value into the list
;; before each insn (or its label).
-(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
- (let ((length (length bytes))
- (ptr 0) optr tags op offset
+(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec
+ &optional make-spliceable)
+ (let ((length (length bytedecomp-bytes))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
lap tmp
endtag)
- (while (not (= ptr length))
+ (while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons ptr lap)))
- (setq op (aref bytes ptr)
- optr ptr
+ (setq lap (cons bytedecomp-ptr lap)))
+ (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
+ optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq op (aref byte-code-vector op))
- (cond ((memq op byte-goto-ops)
+ (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
+ (cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc
(setq offset
(cdr (or (assq offset tags)
@@ -1389,36 +1393,37 @@
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
- ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
- ((memq op byte-constref-ops)))
+ ((cond ((eq bytedecomp-op 'byte-constant2)
+ (setq bytedecomp-op 'byte-constant) t)
+ ((memq bytedecomp-op byte-constref-ops)))
(setq tmp (if (>= offset (length constvec))
(list 'out-of-range offset)
(aref constvec offset))
- offset (if (eq op 'byte-constant)
+ offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
((and make-spliceable
- (eq op 'byte-return))
- (if (= ptr (1- length))
- (setq op nil)
+ (eq bytedecomp-op 'byte-return))
+ (if (= bytedecomp-ptr (1- length))
+ (setq bytedecomp-op nil)
(setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- op 'byte-goto)))
- ((eq op 'byte-stack-set2)
- (setq op 'byte-stack-set))
- ((and (eq op 'byte-discardN) (>= offset #x80))
+ bytedecomp-op 'byte-goto)))
+ ((eq bytedecomp-op 'byte-stack-set2)
+ (setq bytedecomp-op 'byte-stack-set))
+ ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
;; The top bit of the operand for byte-discardN is a flag,
;; saying whether the top-of-stack is preserved. In
;; lapcode, we represent this by using a different opcode
;; (with the flag removed from the operand).
- (setq op 'byte-discardN-preserve-tos)
+ (setq bytedecomp-op 'byte-discardN-preserve-tos)
(setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
- (setq lap (cons (cons optr (cons op (or offset 0)))
+ (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
lap))
- (setq ptr (1+ ptr)))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
@@ -2211,5 +2216,4 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
byte-optimize-lapcode))))
nil)
-;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1
;;; byte-opt.el ends here
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5e975174f01..90fcf7fb8a6 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -37,6 +37,7 @@
;; ========================================================================
;; Entry points:
;; byte-recompile-directory, byte-compile-file,
+;; byte-recompile-file,
;; batch-byte-compile, batch-byte-recompile-directory,
;; byte-compile, compile-defun,
;; display-call-tree
@@ -290,10 +291,14 @@ This option is enabled by default because it reduces Emacs memory usage."
:type 'boolean)
;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp)
+(defconst byte-compile-log-buffer "*Compile-Log*"
+ "Name of the byte-compiler's log buffer.")
+
(defcustom byte-optimize-log nil
- "If true, the byte-compiler will log its optimizations into *Compile-Log*.
+ "If non-nil, the byte-compiler will log its optimizations.
If this is 'source, then only source-level optimizations will be logged.
-If it is 'byte, then only byte-level optimizations will be logged."
+If it is 'byte, then only byte-level optimizations will be logged.
+The information is logged to `byte-compile-log-buffer'."
:group 'bytecomp
:type '(choice (const :tag "none" nil)
(const :tag "all" t)
@@ -339,21 +344,12 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar."
(set :menu-tag "Some"
,@(mapcar (lambda (x) `(const ,x))
byte-compile-warning-types))))
-;;;###autoload(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p)
;;;###autoload
-(defun byte-compile-warnings-safe-p (x)
- "Return non-nil if X is valid as a value of `byte-compile-warnings'."
- (or (booleanp x)
- (and (listp x)
- (if (eq (car x) 'not) (setq x (cdr x))
- t)
- (equal (mapcar
- (lambda (e)
- (when (memq e byte-compile-warning-types)
- e))
- x)
- x))))
+(put 'byte-compile-warnings 'safe-local-variable
+ (lambda (v)
+ (or (symbolp v)
+ (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
(defun byte-compile-warning-enabled-p (warning)
"Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
@@ -1002,7 +998,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Log something that isn't a warning.
(defun byte-compile-log-1 (string)
- (with-current-buffer "*Compile-Log*"
+ (with-current-buffer byte-compile-log-buffer
(let ((inhibit-read-only t))
(goto-char (point-max))
(byte-compile-warning-prefix nil nil)
@@ -1110,13 +1106,13 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; (compile-mode) will cause this to be loaded.
(declare-function compilation-forget-errors "compile" ())
-;; Log the start of a file in *Compile-Log*, and mark it as done.
+;; Log the start of a file in `byte-compile-log-buffer', and mark it as done.
;; Return the position of the start of the page in the log buffer.
;; But do nothing in batch mode.
(defun byte-compile-log-file ()
(and (not (equal byte-compile-current-file byte-compile-last-logged-file))
(not noninteractive)
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(goto-char (point-max))
(let* ((inhibit-read-only t)
(dir (and byte-compile-current-file
@@ -1147,14 +1143,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(compilation-forget-errors)
pt))))
-;; Log a message STRING in *Compile-Log*.
+;; Log a message STRING in `byte-compile-log-buffer'.
;; Also log the current function and file if not already done.
(defun byte-compile-log-warning (string &optional fill level)
(let ((warning-prefix-function 'byte-compile-warning-prefix)
(warning-type-format "")
(warning-fill-prefix (if fill " "))
(inhibit-read-only t))
- (display-warning 'bytecomp string level "*Compile-Log*")))
+ (display-warning 'bytecomp string level byte-compile-log-buffer)))
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format FORMAT ARGS...) for message."
@@ -1570,7 +1566,7 @@ symbol itself."
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
- (get-buffer "*Compile-Log*")))))
+ (get-buffer byte-compile-log-buffer)))))
(byte-compile-find-cl-functions)
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
@@ -1632,7 +1628,7 @@ that already has a `.elc' file."
nil
(save-some-buffers)
(force-mode-line-update))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(setq default-directory (expand-file-name bytecomp-directory))
;; compilation-mode copies value of default-directory.
(unless (eq major-mode 'compilation-mode)
@@ -1669,23 +1665,10 @@ that already has a `.elc' file."
(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)
- ;; File was already compiled.
- (or bytecomp-force
- (file-newer-than-file-p bytecomp-source
- bytecomp-dest))
- ;; No compiled file exists yet.
- (and bytecomp-arg
- (or (eq 0 bytecomp-arg)
- (y-or-n-p (concat "Compile "
- bytecomp-source "? "))))))
- (progn (if (and noninteractive (not byte-compile-verbose))
- (message "Compiling %s..." bytecomp-source))
- (let ((bytecomp-res (byte-compile-file
- bytecomp-source)))
+ bytecomp-source))))
+ (progn (let ((bytecomp-res (byte-recompile-file
+ bytecomp-source
+ bytecomp-force bytecomp-arg)))
(cond ((eq bytecomp-res 'no-byte-compile)
(setq skip-count (1+ skip-count)))
((eq bytecomp-res t)
@@ -1713,6 +1696,60 @@ This is normally set in local file variables at the end of the elisp file:
;; Local Variables:\n;; no-byte-compile: t\n;; End: ")
;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp)
+(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load)
+ "Recompile BYTECOMP-FILENAME file if it needs recompilation.
+This happens when its `.elc' file is older than itself.
+
+If the `.elc' file exists and is up-to-date, normally this
+function *does not* compile BYTECOMP-FILENAME. However, if the
+prefix argument BYTECOMP-FORCE is set, that means do compile
+BYTECOMP-FILENAME even if the destination already exists and is
+up-to-date.
+
+If the `.elc' file does not exist, normally this function *does
+not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means
+compile the file even if it has never been compiled before.
+A nonzero BYTECOMP-ARG means ask the user.
+
+If LOAD is set, `load' the file after compiling.
+
+The value returned is the value returned by `byte-compile-file',
+or 'no-byte-compile if the file did not need recompilation."
+ (interactive
+ (let ((bytecomp-file buffer-file-name)
+ (bytecomp-file-name nil)
+ (bytecomp-file-dir nil))
+ (and bytecomp-file
+ (eq (cdr (assq 'major-mode (buffer-local-variables)))
+ 'emacs-lisp-mode)
+ (setq bytecomp-file-name (file-name-nondirectory bytecomp-file)
+ bytecomp-file-dir (file-name-directory bytecomp-file)))
+ (list (read-file-name (if current-prefix-arg
+ "Byte compile file: "
+ "Byte recompile file: ")
+ bytecomp-file-dir bytecomp-file-name nil)
+ current-prefix-arg)))
+ (let ((bytecomp-dest
+ (byte-compile-dest-file bytecomp-filename))
+ ;; Expand now so we get the current buffer's defaults
+ (bytecomp-filename (expand-file-name bytecomp-filename)))
+ (if (if (file-exists-p bytecomp-dest)
+ ;; File was already compiled
+ ;; Compile if forced to, or filename newer
+ (or bytecomp-force
+ (file-newer-than-file-p bytecomp-filename
+ bytecomp-dest))
+ (and bytecomp-arg
+ (or (eq 0 bytecomp-arg)
+ (y-or-n-p (concat "Compile "
+ bytecomp-filename "? ")))))
+ (progn
+ (if (and noninteractive (not byte-compile-verbose))
+ (message "Compiling %s..." bytecomp-filename))
+ (byte-compile-file bytecomp-filename load))
+ (when load (load bytecomp-filename))
+ 'no-byte-compile)))
+
;;;###autoload
(defun byte-compile-file (bytecomp-filename &optional load)
"Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code.
@@ -4717,5 +4754,4 @@ and corresponding effects."
(run-hooks 'bytecomp-load-hook)
-;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a
;;; bytecomp.el ends here
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index 88da7aab3be..84bfd706afc 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -1,7 +1,7 @@
;;; chart.el --- Draw charts (bar charts, etc)
-;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
@@ -525,9 +525,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details."
(defun chart-zap-chars (n)
"Zap up to N chars without deleting EOLs."
(if (not (eobp))
- (if (< n (- (save-excursion (end-of-line) (point)) (point)))
+ (if (< n (- (point-at-eol) (point)))
(delete-char n)
- (delete-region (point) (save-excursion (end-of-line) (point))))))
+ (delete-region (point) (point-at-eol)))))
(defun chart-display-label (label dir zone start end &optional face)
"Display LABEL in direction DIR in column/row ZONE between START and END.
@@ -746,5 +746,4 @@ SORT-PRED if desired."
(provide 'chart)
-;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59
;;; chart.el ends here
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 9acad6e67cb..0a3b3c94ff6 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -201,9 +201,9 @@ without asking, and complex changes are made by asking the user first.
The value `never' is the same as nil, never ask or change anything."
:group 'checkdoc
:type '(choice (const automatic)
- (const query)
- (const never)
- (other :tag "semiautomatic" semiautomatic)))
+ (const query)
+ (const never)
+ (other :tag "semiautomatic" semiautomatic)))
(defcustom checkdoc-bouncy-flag t
"Non-nil means to \"bounce\" to auto-fix locations.
@@ -250,10 +250,10 @@ system. Possible values are:
t - Always spell-check"
:group 'checkdoc
:type '(choice (const nil)
- (const defun)
- (const buffer)
- (const interactive)
- (const t)))
+ (const defun)
+ (const buffer)
+ (const interactive)
+ (const t)))
(defvar checkdoc-ispell-lisp-words
'("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs")
@@ -429,19 +429,15 @@ and experimental check. Do not modify this list without setting
the value of `checkdoc-common-verbs-regexp' to nil which cause it to
be re-created.")
-(defvar checkdoc-syntax-table nil
+(defvar checkdoc-syntax-table
+ (let ((st (make-syntax-table emacs-lisp-mode-syntax-table)))
+ ;; When dealing with syntax in doc strings, make sure that - are
+ ;; encompassed in words so we can use cheap \\> to get the end of a symbol,
+ ;; not the end of a word in a conglomerate.
+ (modify-syntax-entry ?- "w" st)
+ st)
"Syntax table used by checkdoc in document strings.")
-(if checkdoc-syntax-table
- nil
- (setq checkdoc-syntax-table (copy-syntax-table emacs-lisp-mode-syntax-table))
- ;; When dealing with syntax in doc strings, make sure that - are encompassed
- ;; in words so we can use cheap \\> to get the end of a symbol, not the
- ;; end of a word in a conglomerate.
- (modify-syntax-entry ?- "w" checkdoc-syntax-table)
- )
-
-
;;; Compatibility
;;
(defalias 'checkdoc-make-overlay
@@ -515,12 +511,11 @@ CHECK is a list of four strings stating the current status of each
test; the nth string describes the status of the nth test."
(let (temp-buffer-setup-hook)
(with-output-to-temp-buffer "*Checkdoc Status*"
- (princ-list
- "Buffer comments and tags: " (nth 0 check) "\n"
- "Documentation style: " (nth 1 check) "\n"
- "Message/Query text style: " (nth 2 check) "\n"
- "Unwanted Spaces: " (nth 3 check)
- )))
+ (mapc #'princ
+ (list "Buffer comments and tags: " (nth 0 check)
+ "\nDocumentation style: " (nth 1 check)
+ "\nMessage/Query text style: " (nth 2 check)
+ "\nUnwanted Spaces: " (nth 3 check)))))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Status*"))
(message nil)
@@ -623,7 +618,7 @@ style."
(recenter (/ (- (window-height) l) 2))))
(recenter))
(message "%s (C-h,%se,n,p,q)" (checkdoc-error-text
- (car (car err-list)))
+ (car (car err-list)))
(if (checkdoc-error-unfixable (car (car err-list)))
"" "f,"))
(save-excursion
@@ -713,20 +708,21 @@ style."
(delete-window (get-buffer-window "*Checkdoc Help*"))
(kill-buffer "*Checkdoc Help*"))
(with-output-to-temp-buffer "*Checkdoc Help*"
- (princ-list
- "Checkdoc Keyboard Summary:\n"
- (if (checkdoc-error-unfixable (car (car err-list)))
- ""
- (concat
- "f, y - auto Fix this warning without asking (if\
+ (with-current-buffer standard-output
+ (insert
+ "Checkdoc Keyboard Summary:\n"
+ (if (checkdoc-error-unfixable (car (car err-list)))
+ ""
+ (concat
+ "f, y - auto Fix this warning without asking (if\
available.)\n"
- " Very complex operations will still query.\n")
- )
- "e - Enter recursive Edit. Press C-M-c to exit.\n"
- "SPC, n - skip to the Next error.\n"
- "DEL, p - skip to the Previous error.\n"
- "q - Quit checkdoc.\n"
- "C-h - Toggle this help buffer."))
+ " Very complex operations will still query.\n")
+ )
+ "e - Enter recursive Edit. Press C-M-c to exit.\n"
+ "SPC, n - skip to the Next error.\n"
+ "DEL, p - skip to the Previous error.\n"
+ "q - Quit checkdoc.\n"
+ "C-h - Toggle this help buffer.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))))))
(if cdo (checkdoc-delete-overlay cdo)))))
@@ -826,9 +822,9 @@ assumes that the cursor is already positioned to perform the fix."
"Enter recursive edit to permit a user to fix some error checkdoc has found.
MSG is the error that was found, which is displayed in a help buffer."
(with-output-to-temp-buffer "*Checkdoc Help*"
- (princ-list
- "Error message:\n " msg
- "\n\nEdit to fix this problem, and press C-M-c to continue."))
+ (mapc #'princ
+ (list "Error message:\n " msg
+ "\n\nEdit to fix this problem, and press C-M-c to continue.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))
(message "When you're done editing press C-M-c to continue.")
@@ -947,14 +943,14 @@ if there is one."
(interactive "P")
(if take-notes (checkdoc-start-section "checkdoc-comments"))
(if (not buffer-file-name)
- (error "Can only check comments for a file buffer"))
+ (error "Can only check comments for a file buffer"))
(let* ((checkdoc-spellcheck-documentation-flag
(car (memq checkdoc-spellcheck-documentation-flag
'(buffer t))))
(checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag))
(e (checkdoc-file-comments-engine))
- (checkdoc-generate-compile-warnings-flag
- (or take-notes checkdoc-generate-compile-warnings-flag)))
+ (checkdoc-generate-compile-warnings-flag
+ (or take-notes checkdoc-generate-compile-warnings-flag)))
(if e (error "%s" (checkdoc-error-text e)))
(checkdoc-show-diagnostics)
e))
@@ -970,8 +966,8 @@ Optional argument INTERACT permits more interactive fixing."
(if take-notes (checkdoc-start-section "checkdoc-rogue-spaces"))
(let* ((checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag))
(e (checkdoc-rogue-space-check-engine nil nil interact))
- (checkdoc-generate-compile-warnings-flag
- (or take-notes checkdoc-generate-compile-warnings-flag)))
+ (checkdoc-generate-compile-warnings-flag
+ (or take-notes checkdoc-generate-compile-warnings-flag)))
(if (not (called-interactively-p 'interactive))
e
(if e
@@ -1210,34 +1206,34 @@ generating a buffered list of errors."
;; Add in a menubar with easy-menu
(easy-menu-define
- nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu"
- '("CheckDoc"
- ["Interactive Buffer Style Check" checkdoc t]
- ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t]
- ["Check Buffer" checkdoc-current-buffer t]
- ["Check and Spell Buffer" checkdoc-ispell-current-buffer t]
- "---"
- ["Interactive Style Check" checkdoc-interactive t]
- ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t]
- ["Find First Style Error" checkdoc-start t]
- ["Find First Style or Spelling Error" checkdoc-ispell-start t]
- ["Next Style Error" checkdoc-continue t]
- ["Next Style or Spelling Error" checkdoc-ispell-continue t]
- ["Interactive Message Text Style Check" checkdoc-message-interactive t]
- ["Interactive Message Text Style and Spelling Check"
- checkdoc-ispell-message-interactive t]
- ["Check Message Text" checkdoc-message-text t]
- ["Check and Spell Message Text" checkdoc-ispell-message-text t]
- ["Check Comment Style" checkdoc-comments buffer-file-name]
- ["Check Comment Style and Spelling" checkdoc-ispell-comments
- buffer-file-name]
- ["Check for Rogue Spaces" checkdoc-rogue-spaces t]
- "---"
- ["Check Defun" checkdoc-defun t]
- ["Check and Spell Defun" checkdoc-ispell-defun t]
- ["Check and Evaluate Defun" checkdoc-eval-defun t]
- ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t]
- ))
+ nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu"
+ '("CheckDoc"
+ ["Interactive Buffer Style Check" checkdoc t]
+ ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t]
+ ["Check Buffer" checkdoc-current-buffer t]
+ ["Check and Spell Buffer" checkdoc-ispell-current-buffer t]
+ "---"
+ ["Interactive Style Check" checkdoc-interactive t]
+ ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t]
+ ["Find First Style Error" checkdoc-start t]
+ ["Find First Style or Spelling Error" checkdoc-ispell-start t]
+ ["Next Style Error" checkdoc-continue t]
+ ["Next Style or Spelling Error" checkdoc-ispell-continue t]
+ ["Interactive Message Text Style Check" checkdoc-message-interactive t]
+ ["Interactive Message Text Style and Spelling Check"
+ checkdoc-ispell-message-interactive t]
+ ["Check Message Text" checkdoc-message-text t]
+ ["Check and Spell Message Text" checkdoc-ispell-message-text t]
+ ["Check Comment Style" checkdoc-comments buffer-file-name]
+ ["Check Comment Style and Spelling" checkdoc-ispell-comments
+ buffer-file-name]
+ ["Check for Rogue Spaces" checkdoc-rogue-spaces t]
+ "---"
+ ["Check Defun" checkdoc-defun t]
+ ["Check and Spell Defun" checkdoc-ispell-defun t]
+ ["Check and Evaluate Defun" checkdoc-eval-defun t]
+ ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t]
+ ))
;; XEmacs requires some weird stuff to add this menu in a minor mode.
;; What is it?
@@ -1366,7 +1362,7 @@ See the style guide in the Emacs Lisp manual for more details."
(setq checkdoc-autofix-flag 'never))))
(checkdoc-create-error
"You should convert this comment to documentation"
- (point) (save-excursion (end-of-line) (point))))
+ (point) (line-end-position)))
(checkdoc-create-error
(if (nth 2 fp)
"All interactive functions should have documentation"
@@ -1374,12 +1370,8 @@ See the style guide in the Emacs Lisp manual for more details."
documentation string")
(point) (+ (point) 1) t)))))
(if (and (not err) (looking-at "\""))
- (let ((old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (checkdoc-this-string-valid-engine fp))
- (set-syntax-table old-syntax-table)))
+ (with-syntax-table checkdoc-syntax-table
+ (checkdoc-this-string-valid-engine fp))
err)))
(defun checkdoc-this-string-valid-engine (fp)
@@ -1388,7 +1380,7 @@ Depends on `checkdoc-this-string-valid' to reset the syntax table so that
regexp short cuts work. FP is the function defun information."
(let ((case-fold-search nil)
;; Use a marker so if an early check modifies the text,
- ;; we won't accidentally loose our place. This could cause
+ ;; we won't accidentally lose our place. This could cause
;; end-of doc string whitespace to also delete the " char.
(s (point))
(e (if (looking-at "\"")
@@ -1486,12 +1478,10 @@ regexp short cuts work. FP is the function defun information."
"First line not a complete sentence. Add RET here? "
"\n" t)
(let (l1 l2)
- (forward-line 1)
- (end-of-line)
+ (end-of-line 2)
(setq l1 (current-column)
l2 (save-excursion
- (forward-line 1)
- (end-of-line)
+ (end-of-line 2)
(current-column)))
(if (> (+ l1 l2 1) 80)
(setq msg "Incomplete auto-fix; doc string \
@@ -1508,10 +1498,7 @@ may require more formatting")
(forward-line 1)
(beginning-of-line)
(if (and (re-search-forward "[.!?:\"]\\([ \t\n]+\\|\"\\)"
- (save-excursion
- (end-of-line)
- (point))
- t)
+ (line-end-position) t)
(< (current-column) numc))
(if (checkdoc-autofix-ask-replace
p (1+ p)
@@ -1526,9 +1513,7 @@ may require more formatting")
(if msg
(checkdoc-create-error msg s (save-excursion
(goto-char s)
- (end-of-line)
- (point)))
- nil) ))))
+ (line-end-position))))))))
;; Continuation of above. Make sure our sentence is capitalized.
(save-excursion
(skip-chars-forward "\"\\*")
@@ -1628,7 +1613,7 @@ function,command,variable,option or symbol." ms1))))))
(if (and (< (point) e) (> (current-column) 80))
(checkdoc-create-error
"Some lines are over 80 columns wide"
- s (save-excursion (goto-char s) (end-of-line) (point)) ))))
+ s (save-excursion (goto-char s) (line-end-position))))))
;; Here we deviate to tests based on a variable or function.
;; We must do this before checking for symbols in quotes because there
;; is a chance that just such a symbol might really be an argument.
@@ -1773,9 +1758,8 @@ function,command,variable,option or symbol." ms1))))))
(end-of-line)
;; check string-continuation
(if (checkdoc-char= (preceding-char) ?\\)
- (progn (forward-line 1)
- (end-of-line)))
- (point)))
+ (line-end-position 2)
+ (point))))
(rs nil) replace original (case-fold-search t))
(while (and (not rs)
(re-search-forward
@@ -1999,49 +1983,45 @@ internally skip over no answers.
If the offending word is in a piece of quoted text, then it is skipped."
(save-excursion
(let ((case-fold-search nil)
- (errtxt nil) bb be
- (old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (goto-char begin)
- (while (re-search-forward checkdoc-proper-noun-regexp end t)
- (let ((text (match-string 1))
- (b (match-beginning 1))
- (e (match-end 1)))
- (if (and (not (save-excursion
- (goto-char b)
- (forward-char -1)
- (looking-at "`\\|\"\\|\\.\\|\\\\")))
- ;; surrounded by /, as in a URL or filename: /emacs/
- (not (and (= ?/ (char-after e))
- (= ?/ (char-before b))))
- (not (checkdoc-in-example-string-p begin end))
- ;; info or url links left alone
- (not (thing-at-point-looking-at
- help-xref-info-regexp))
- (not (thing-at-point-looking-at
- help-xref-url-regexp)))
- (if (checkdoc-autofix-ask-replace
- b e (format "Text %s should be capitalized. Fix? "
- text)
- (capitalize text) t)
- nil
- (if errtxt
- ;; If there is already an error, then generate
- ;; the warning output if applicable
- (if checkdoc-generate-compile-warnings-flag
- (checkdoc-create-error
- (format
- "Name %s should appear capitalized as %s"
- text (capitalize text))
- b e))
- (setq errtxt
- (format
- "Name %s should appear capitalized as %s"
- text (capitalize text))
- bb b be e)))))))
- (set-syntax-table old-syntax-table))
+ (errtxt nil) bb be)
+ (with-syntax-table checkdoc-syntax-table
+ (goto-char begin)
+ (while (re-search-forward checkdoc-proper-noun-regexp end t)
+ (let ((text (match-string 1))
+ (b (match-beginning 1))
+ (e (match-end 1)))
+ (if (and (not (save-excursion
+ (goto-char b)
+ (forward-char -1)
+ (looking-at "`\\|\"\\|\\.\\|\\\\")))
+ ;; surrounded by /, as in a URL or filename: /emacs/
+ (not (and (= ?/ (char-after e))
+ (= ?/ (char-before b))))
+ (not (checkdoc-in-example-string-p begin end))
+ ;; info or url links left alone
+ (not (thing-at-point-looking-at
+ help-xref-info-regexp))
+ (not (thing-at-point-looking-at
+ help-xref-url-regexp)))
+ (if (checkdoc-autofix-ask-replace
+ b e (format "Text %s should be capitalized. Fix? "
+ text)
+ (capitalize text) t)
+ nil
+ (if errtxt
+ ;; If there is already an error, then generate
+ ;; the warning output if applicable
+ (if checkdoc-generate-compile-warnings-flag
+ (checkdoc-create-error
+ (format
+ "Name %s should appear capitalized as %s"
+ text (capitalize text))
+ b e))
+ (setq errtxt
+ (format
+ "Name %s should appear capitalized as %s"
+ text (capitalize text))
+ bb b be e)))))))
(if errtxt (checkdoc-create-error errtxt bb be)))))
(defun checkdoc-sentencespace-region-engine (begin end)
@@ -2049,43 +2029,39 @@ If the offending word is in a piece of quoted text, then it is skipped."
(if sentence-end-double-space
(save-excursion
(let ((case-fold-search nil)
- (errtxt nil) bb be
- (old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (goto-char begin)
- (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t)
- (let ((b (match-beginning 1))
- (e (match-end 1)))
- (unless (or (checkdoc-in-sample-code-p begin end)
- (checkdoc-in-example-string-p begin end)
- (save-excursion
- (goto-char b)
- (condition-case nil
- (progn
- (forward-sexp -1)
- ;; piece of an abbreviation
- ;; FIXME etc
- (looking-at
- "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\."))
- (error t))))
- (if (checkdoc-autofix-ask-replace
- b e
- "There should be two spaces after a period. Fix? "
- ". ")
- nil
- (if errtxt
- ;; If there is already an error, then generate
- ;; the warning output if applicable
- (if checkdoc-generate-compile-warnings-flag
- (checkdoc-create-error
- "There should be two spaces after a period"
- b e))
- (setq errtxt
- "There should be two spaces after a period"
- bb b be e)))))))
- (set-syntax-table old-syntax-table))
+ (errtxt nil) bb be)
+ (with-syntax-table checkdoc-syntax-table
+ (goto-char begin)
+ (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t)
+ (let ((b (match-beginning 1))
+ (e (match-end 1)))
+ (unless (or (checkdoc-in-sample-code-p begin end)
+ (checkdoc-in-example-string-p begin end)
+ (save-excursion
+ (goto-char b)
+ (condition-case nil
+ (progn
+ (forward-sexp -1)
+ ;; piece of an abbreviation
+ ;; FIXME etc
+ (looking-at
+ "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\."))
+ (error t))))
+ (if (checkdoc-autofix-ask-replace
+ b e
+ "There should be two spaces after a period. Fix? "
+ ". ")
+ nil
+ (if errtxt
+ ;; If there is already an error, then generate
+ ;; the warning output if applicable
+ (if checkdoc-generate-compile-warnings-flag
+ (checkdoc-create-error
+ "There should be two spaces after a period"
+ b e))
+ (setq errtxt
+ "There should be two spaces after a period"
+ bb b be e)))))))
(if errtxt (checkdoc-create-error errtxt bb be))))))
;;; Ispell engine
@@ -2253,8 +2229,8 @@ Code:, and others referenced in the style guide."
(insert ";;; " fn fe " --- " (read-string "Summary: ") "\n"))
(checkdoc-create-error
"The first line should be of the form: \";;; package --- Summary\""
- (point-min) (save-excursion (goto-char (point-min)) (end-of-line)
- (point))))
+ (point-min) (save-excursion (goto-char (point-min))
+ (line-end-position))))
nil))
(setq
err
@@ -2665,8 +2641,7 @@ function called to create the messages."
(setq checkdoc-pending-errors nil)
nil)))
-(custom-add-option 'emacs-lisp-mode-hook
- (lambda () (checkdoc-minor-mode 1)))
+(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode)
(add-to-list 'debug-ignored-errors
"Argument `.*' should appear (as .*) in the doc string")
@@ -2676,5 +2651,4 @@ function called to create the messages."
(provide 'checkdoc)
-;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26
;;; checkdoc.el ends here
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index db2ae88b8b7..74d7432bec6 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -282,7 +282,7 @@ Not documented
;;;;;; 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")
+;;;;;; gensym) "cl-macs" "cl-macs.el" "34ea402a8756c7d74d27cdcecf35e3c3")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index f6d66c64c7a..725b98354af 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -639,7 +639,7 @@ This is compatible with Common Lisp, but note that `defun' and
;;; The "loop" macro.
-(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
+(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
@@ -647,7 +647,7 @@ This is compatible with Common Lisp, but note that `defun' and
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
;;;###autoload
-(defmacro loop (&rest args)
+(defmacro loop (&rest loop-args)
"The Common Lisp `loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
@@ -662,8 +662,8 @@ Valid clauses are:
finally return EXPR, named NAME.
\(fn CLAUSE...)"
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
- (list 'block nil (list* 'while t args))
+ (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
+ (list 'block nil (list* 'while t loop-args))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
(loop-result nil) (loop-result-explicit nil)
@@ -672,8 +672,8 @@ Valid clauses are:
(loop-initially nil) (loop-finally nil)
(loop-map-form nil) (loop-first-flag nil)
(loop-destr-temps nil) (loop-symbol-macs nil))
- (setq args (append args '(cl-end-loop)))
- (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
+ (setq loop-args (append loop-args '(cl-end-loop)))
+ (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
(if loop-finish-flag
(push `((,loop-finish-flag t)) loop-bindings))
(if loop-first-flag
@@ -713,34 +713,34 @@ Valid clauses are:
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
-(defun cl-parse-loop-clause () ; uses args, loop-*
- (let ((word (pop args))
+(defun cl-parse-loop-clause () ; uses loop-*
+ (let ((word (pop loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
- ((null args)
+ ((null loop-args)
(error "Malformed `loop' macro"))
((eq word 'named)
- (setq loop-name (pop args)))
+ (setq loop-name (pop loop-args)))
((eq word 'initially)
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `initially' clause"))
- (while (consp (car args))
- (push (pop args) loop-initially)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-initially)))
((eq word 'finally)
- (if (eq (car args) 'return)
- (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `finally' clause"))
- (if (and (eq (caar args) 'return) (null loop-name))
- (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
- (while (consp (car args))
- (push (pop args) loop-finally)))))
+ (if (eq (car loop-args) 'return)
+ (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
+ (if (and (eq (caar loop-args) 'return) (null loop-name))
+ (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
@@ -749,29 +749,29 @@ Valid clauses are:
;; Use `gensym' rather than `make-symbol'. It's important that
;; (not (eq (symbol-name var1) (symbol-name var2))) because
;; these vars get added to the cl-macro-environment.
- (let ((var (or (pop args) (gensym "--cl-var--"))))
- (setq word (pop args))
- (if (eq word 'being) (setq word (pop args)))
- (if (memq word '(the each)) (setq word (pop args)))
+ (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
+ (setq word (pop loop-args))
+ (if (eq word 'being) (setq word (pop loop-args)))
+ (if (memq word '(the each)) (setq word (pop loop-args)))
(if (memq word '(buffer buffers))
- (setq word 'in args (cons '(buffer-list) args)))
+ (setq word 'in loop-args (cons '(buffer-list) loop-args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
- (push word args)
- (if (memq (car args) '(downto above))
+ (push word loop-args)
+ (if (memq (car loop-args) '(downto above))
(error "Must specify `from' value for downward loop"))
- (let* ((down (or (eq (car args) 'downfrom)
- (memq (caddr args) '(downto above))))
- (excl (or (memq (car args) '(above below))
- (memq (caddr args) '(above below))))
- (start (and (memq (car args) '(from upfrom downfrom))
- (cl-pop2 args)))
- (end (and (memq (car args)
+ (let* ((down (or (eq (car loop-args) 'downfrom)
+ (memq (caddr loop-args) '(downto above))))
+ (excl (or (memq (car loop-args) '(above below))
+ (memq (caddr loop-args) '(above below))))
+ (start (and (memq (car loop-args) '(from upfrom downfrom))
+ (cl-pop2 loop-args)))
+ (end (and (memq (car loop-args)
'(to upto downto above below))
- (cl-pop2 args)))
- (step (and (eq (car args) 'by) (cl-pop2 args)))
+ (cl-pop2 loop-args)))
+ (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
(end-var (and (not (cl-const-expr-p end))
(make-symbol "--cl-var--")))
(step-var (and (not (cl-const-expr-p step))
@@ -794,7 +794,7 @@ Valid clauses are:
(let* ((on (eq word 'on))
(temp (if (and on (symbolp var))
var (make-symbol "--cl-var--"))))
- (push (list temp (pop args)) loop-for-bindings)
+ (push (list temp (pop loop-args)) loop-for-bindings)
(push (list 'consp temp) loop-body)
(if (eq word 'in-ref)
(push (list var (list 'car temp)) loop-symbol-macs)
@@ -804,8 +804,8 @@ Valid clauses are:
(push (list var (if on temp (list 'car temp)))
loop-for-sets))))
(push (list temp
- (if (eq (car args) 'by)
- (let ((step (cl-pop2 args)))
+ (if (eq (car loop-args) 'by)
+ (let ((step (cl-pop2 loop-args)))
(if (and (memq (car-safe step)
'(quote function
function*))
@@ -816,10 +816,10 @@ Valid clauses are:
loop-for-steps)))
((eq word '=)
- (let* ((start (pop args))
- (then (if (eq (car args) 'then) (cl-pop2 args) start)))
+ (let* ((start (pop loop-args))
+ (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
(push (list var nil) loop-for-bindings)
- (if (or ands (eq (car args) 'and))
+ (if (or ands (eq (car loop-args) 'and))
(progn
(push `(,var
(if ,(or loop-first-flag
@@ -839,7 +839,7 @@ Valid clauses are:
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
(temp-idx (make-symbol "--cl-idx--")))
- (push (list temp-vec (pop args)) loop-for-bindings)
+ (push (list temp-vec (pop loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push (list '< (list 'setq temp-idx (list '1+ temp-idx))
(list 'length temp-vec)) loop-body)
@@ -851,15 +851,15 @@ Valid clauses are:
loop-for-sets))))
((memq word '(element elements))
- (let ((ref (or (memq (car args) '(in-ref of-ref))
- (and (not (memq (car args) '(in of)))
+ (let ((ref (or (memq (car loop-args) '(in-ref of-ref))
+ (and (not (memq (car loop-args) '(in of)))
(error "Expected `of'"))))
- (seq (cl-pop2 args))
+ (seq (cl-pop2 loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-idx (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (eq (caadr args) 'index))
- (cadr (cl-pop2 args))
+ (temp-idx (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (eq (caadr loop-args) 'index))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-idx--"))))
(push (list temp-seq seq) loop-for-bindings)
@@ -885,13 +885,13 @@ Valid clauses are:
loop-for-steps)))
((memq word hash-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let* ((table (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) hash-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let* ((table (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) hash-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
@@ -901,16 +901,16 @@ Valid clauses are:
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
- (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
+ (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
(setq loop-map-form
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
((memq word '(overlay overlays extent extents))
(let ((buf nil) (from nil) (to nil))
- (while (memq (car args) '(in of from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(setq loop-map-form
`(cl-map-extents
(lambda (,var ,(make-symbol "--cl-var--"))
@@ -921,12 +921,12 @@ Valid clauses are:
(let ((buf nil) (prop nil) (from nil) (to nil)
(var1 (make-symbol "--cl-var1--"))
(var2 (make-symbol "--cl-var2--")))
- (while (memq (car args) '(in of property from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- ((eq (car args) 'property)
- (setq prop (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of property from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'property)
+ (setq prop (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var (list 'cons var1 var2)) loop-for-sets))
@@ -936,13 +936,13 @@ Valid clauses are:
,buf ,prop ,from ,to))))
((memq word key-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let ((map (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) key-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let ((map (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) key-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
@@ -964,17 +964,26 @@ Valid clauses are:
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
- (temp (make-symbol "--cl-var--")))
+ (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
+ (temp (make-symbol "--cl-var--"))
+ (minip (make-symbol "--cl-minip--")))
(push (list var (if scr
(list 'frame-selected-window scr)
'(selected-window)))
loop-for-bindings)
+ ;; If we started in the minibuffer, we need to
+ ;; ensure that next-window will bring us back there
+ ;; at some point. (Bug#7492).
+ ;; (Consider using walk-windows instead of loop if
+ ;; you care about such things.)
+ (push (list minip `(minibufferp (window-buffer ,var)))
+ loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push (list 'prog1 (list 'not (list 'eq var temp))
(list 'or temp (list 'setq temp var)))
loop-body)
- (push (list var (list 'next-window var)) loop-for-steps)))
+ (push (list var (list 'next-window var minip))
+ loop-for-steps)))
(t
(let ((handler (and (symbolp word)
@@ -982,9 +991,9 @@ Valid clauses are:
(if handler
(funcall handler var)
(error "Expected a `for' preposition, found %s" word)))))
- (eq (car args) 'and))
+ (eq (car loop-args) 'and))
(setq ands t)
- (pop args))
+ (pop loop-args))
(if (and ands loop-for-bindings)
(push (nreverse loop-for-bindings) loop-bindings)
(setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
@@ -1000,11 +1009,11 @@ Valid clauses are:
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
- (push (list (list temp (pop args))) loop-bindings)
+ (push (list (list temp (pop loop-args))) loop-bindings)
(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
((memq word '(collect collecting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(if (eq var loop-accum-var)
(push (list 'progn (list 'push what var) t) loop-body)
@@ -1013,7 +1022,7 @@ Valid clauses are:
t) loop-body))))
((memq word '(nconc nconcing append appending))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(push (list 'progn
(list 'setq var
@@ -1028,27 +1037,27 @@ Valid clauses are:
var what))) t) loop-body)))
((memq word '(concat concating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum "")))
(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
((memq word '(vconcat vconcating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum [])))
(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
((memq word '(sum summing))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'incf var what) t) loop-body)))
((memq word '(count counting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
((memq word '(minimize minimizing maximize maximizing))
- (let* ((what (pop args))
+ (let* ((what (pop loop-args))
(temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
(var (cl-loop-handle-accum nil))
(func (intern (substring (symbol-name word) 0 3)))
@@ -1059,27 +1068,27 @@ Valid clauses are:
((eq word 'with)
(let ((bindings nil))
- (while (progn (push (list (pop args)
- (and (eq (car args) '=) (cl-pop2 args)))
+ (while (progn (push (list (pop loop-args)
+ (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
bindings)
- (eq (car args) 'and))
- (pop args))
+ (eq (car loop-args) 'and))
+ (pop loop-args))
(push (nreverse bindings) loop-bindings)))
((eq word 'while)
- (push (pop args) loop-body))
+ (push (pop loop-args) loop-body))
((eq word 'until)
- (push (list 'not (pop args)) loop-body))
+ (push (list 'not (pop loop-args)) loop-body))
((eq word 'always)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (pop args)) loop-body)
+ (push (list 'setq loop-finish-flag (pop loop-args)) loop-body)
(setq loop-result t))
((eq word 'never)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (list 'not (pop args)))
+ (push (list 'setq loop-finish-flag (list 'not (pop loop-args)))
loop-body)
(setq loop-result t))
@@ -1087,20 +1096,20 @@ Valid clauses are:
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
(push (list 'setq loop-finish-flag
- (list 'not (list 'setq loop-result-var (pop args))))
+ (list 'not (list 'setq loop-result-var (pop loop-args))))
loop-body))
((memq word '(if when unless))
- (let* ((cond (pop args))
+ (let* ((cond (pop loop-args))
(then (let ((loop-body nil))
(cl-parse-loop-clause)
(cl-loop-build-ands (nreverse loop-body))))
(else (let ((loop-body nil))
- (if (eq (car args) 'else)
- (progn (pop args) (cl-parse-loop-clause)))
+ (if (eq (car loop-args) 'else)
+ (progn (pop loop-args) (cl-parse-loop-clause)))
(cl-loop-build-ands (nreverse loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
- (if (eq (car args) 'end) (pop args))
+ (if (eq (car loop-args) 'end) (pop loop-args))
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
@@ -1114,22 +1123,22 @@ Valid clauses are:
((memq word '(do doing))
(let ((body nil))
- (or (consp (car args)) (error "Syntax error on `do' clause"))
- (while (consp (car args)) (push (pop args) body))
+ (or (consp (car loop-args)) (error "Syntax error on `do' clause"))
+ (while (consp (car loop-args)) (push (pop loop-args) body))
(push (cons 'progn (nreverse (cons t body))) loop-body)))
((eq word 'return)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
- (push (list 'setq loop-result-var (pop args)
+ (push (list 'setq loop-result-var (pop loop-args)
loop-finish-flag nil) loop-body))
(t
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
(or handler (error "Expected a loop keyword, found %s" word))
(funcall handler))))
- (if (eq (car args) 'and)
- (progn (pop args) (cl-parse-loop-clause)))))
+ (if (eq (car loop-args) 'and)
+ (progn (pop loop-args) (cl-parse-loop-clause)))))
(defun cl-loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
@@ -1165,9 +1174,9 @@ Valid clauses are:
(list* (if par 'let 'let*)
(nconc (nreverse temps) (nreverse new)) body))))
-(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-*
- (if (eq (car args) 'into)
- (let ((var (cl-pop2 args)))
+(defun cl-loop-handle-accum (def &optional func) ; uses loop-*
+ (if (eq (car loop-args) 'into)
+ (let ((var (cl-pop2 loop-args)))
(or (memq var loop-accum-vars)
(progn (push (list (list var def)) loop-bindings)
(push var loop-accum-vars)))
@@ -1748,15 +1757,6 @@ Example:
(defsetf default-file-modes set-default-file-modes t)
(defsetf default-value set-default)
(defsetf documentation-property put)
-(defsetf extent-data set-extent-data)
-(defsetf extent-face set-extent-face)
-(defsetf extent-priority set-extent-priority)
-(defsetf extent-end-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
- store) store))
-(defsetf extent-start-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints store
- (list 'extent-end-position ext)) store))
(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
(defsetf face-background-pixmap (f &optional s) (x)
(list 'set-face-background-pixmap f x s))
@@ -2791,5 +2791,4 @@ surrounded by (block NAME ...).
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
-;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index e11572dfc62..9a703c96378 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -119,7 +119,8 @@ BODY contains code to execute each time the mode is enabled or disabled.
of the variable MODE to store the state of the mode. PLACE
can also be of the form (GET . SET) where GET is an expression
that returns the current state and SET is a function that takes
- a new state and sets it.
+ a new state and sets it. If you specify a :variable, this
+ function assumes it is defined elsewhere.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
@@ -196,6 +197,7 @@ For example, you could write
`(:group ',(intern (replace-regexp-in-string
"-mode\\'" "" mode-name)))))
+ ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode.
(unless type (setq type '(:type 'boolean)))
`(progn
@@ -583,5 +585,4 @@ BODY is executed after moving to the destination location."
(provide 'easy-mmode)
-;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a
;;; easy-mmode.el ends here
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 145498b9059..77953b37021 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1,8 +1,8 @@
;;; edebug.el --- a source-level debugger for Emacs Lisp
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Maintainer: FSF
@@ -2991,7 +2991,7 @@ MSG is printed after `::::} '."
;; Set up the overlay arrow at beginning-of-line in current buffer.
;; The arrow string is derived from edebug-arrow-alist and
;; edebug-execution-mode.
- (let ((pos (save-excursion (beginning-of-line) (point))))
+ (let ((pos (line-beginning-position)))
(setq overlay-arrow-string
(cdr (assq edebug-execution-mode edebug-arrow-alist)))
(setq overlay-arrow-position (make-marker))
@@ -4454,5 +4454,4 @@ With prefix argument, make it a temporary breakpoint."
(provide 'edebug)
-;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808
;;; edebug.el ends here
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el
index 0e76f4bb331..e07a7b20d14 100644
--- a/lisp/emacs-lisp/eieio-comp.el
+++ b/lisp/emacs-lisp/eieio-comp.el
@@ -47,10 +47,6 @@
;; This teaches the byte compiler how to do this sort of thing.
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
-;; Variables used free:
-(defvar outbuffer)
-(defvar filename)
-
(defun byte-compile-file-form-defmethod (form)
"Mumble about the method we are compiling.
This function is mostly ripped from `byte-compile-file-form-defun',
@@ -83,14 +79,18 @@ that is called but rarely. Argument FORM is the body of the method."
(class (if (listp arg1) (nth 1 arg1) nil))
(my-outbuffer (if (eval-when-compile (featurep 'xemacs))
byte-compile-outbuffer
- (condition-case nil
- bytecomp-outbuffer
- (error outbuffer))))
- )
+ (cond ((boundp 'bytecomp-outbuffer)
+ bytecomp-outbuffer) ; Emacs >= 23.2
+ ((boundp 'outbuffer) outbuffer)
+ (t (error "Unable to set outbuffer"))))))
(let ((name (format "%s::%s" (or class "#<generic>") meth)))
(if byte-compile-verbose
;; #### filename used free
- (message "Compiling %s... (%s)" (or filename "") name))
+ (message "Compiling %s... (%s)"
+ (cond ((boundp 'bytecomp-filename) bytecomp-filename)
+ ((boundp 'filename) filename)
+ (t ""))
+ name))
(setq byte-compile-current-form name) ; for warnings
)
;; Flush any pending output
@@ -139,5 +139,4 @@ Argument PARAMLIST is the parameter list to convert."
(provide 'eieio-comp)
-;; arch-tag: f2aacdd3-1da2-4ee9-b3e5-e8eac0832ee3
;;; eieio-comp.el ends here
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index b9aa29decd0..39c45e82309 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -394,40 +394,41 @@ Return nil if there are no more forms, t otherwise."
(parse-partial-sexp (point) (point-max) nil t)
(not (eobp)))
-(defvar env) ; from elint-init-env
+(defvar elint-env) ; from elint-init-env
(defun elint-init-form (form)
- "Process FORM, adding to ENV if recognized."
+ "Process FORM, adding to ELINT-ENV if recognized."
(cond
;; Eg nnmaildir seems to use [] as a form of comment syntax.
((not (listp form))
(elint-warning "Skipping non-list form `%s'" form))
;; Add defined variable
((memq (car form) '(defvar defconst defcustom))
- (setq env (elint-env-add-var env (cadr form))))
+ (setq elint-env (elint-env-add-var elint-env (cadr form))))
;; Add function
((memq (car form) '(defun defsubst))
- (setq env (elint-env-add-func env (cadr form) (nth 2 form))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form))))
;; FIXME needs a handler to say second arg is not a variable when we come
;; to scan the form.
((eq (car form) 'define-derived-mode)
- (setq env (elint-env-add-func env (cadr form) ())
- env (elint-env-add-var env (cadr form))
- env (elint-env-add-var env (intern (format "%s-map" (cadr form))))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) ())
+ elint-env (elint-env-add-var elint-env (cadr form))
+ elint-env (elint-env-add-var elint-env
+ (intern (format "%s-map" (cadr form))))))
((eq (car form) 'define-minor-mode)
- (setq env (elint-env-add-func env (cadr form) '(&optional arg))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) '(&optional arg))
;; FIXME mode map?
- env (elint-env-add-var env (cadr form))))
+ elint-env (elint-env-add-var elint-env (cadr form))))
((and (eq (car form) 'easy-menu-define)
(cadr form))
- (setq env (elint-env-add-func env (cadr form) '(event))
- env (elint-env-add-var env (cadr form))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) '(event))
+ elint-env (elint-env-add-var elint-env (cadr form))))
;; FIXME it would be nice to check the autoloads are correct.
((eq (car form) 'autoload)
- (setq env (elint-env-add-func env (cadr (cadr form)) 'unknown)))
+ (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) 'unknown)))
((eq (car form) 'declare-function)
- (setq env (elint-env-add-func
- env (cadr form)
+ (setq elint-env (elint-env-add-func
+ elint-env (cadr form)
(if (or (< (length form) 4)
(eq (nth 3 form) t)
(unless (stringp (nth 2 form))
@@ -440,14 +441,14 @@ Return nil if there are no more forms, t otherwise."
;; If the alias points to something already in the environment,
;; add the alias to the environment with the same arguments.
;; FIXME symbol-function, eg backquote.el?
- (let ((def (elint-env-find-func env (cadr (nth 2 form)))))
- (setq env (elint-env-add-func env (cadr (cadr form))
+ (let ((def (elint-env-find-func elint-env (cadr (nth 2 form)))))
+ (setq elint-env (elint-env-add-func elint-env (cadr (cadr form))
(if def (cadr def) 'unknown)))))
;; Add macro, both as a macro and as a function
((eq (car form) 'defmacro)
- (setq env (elint-env-add-macro env (cadr form)
+ (setq elint-env (elint-env-add-macro elint-env (cadr form)
(cons 'lambda (cddr form)))
- env (elint-env-add-func env (cadr form) (nth 2 form))))
+ elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form))))
((and (eq (car form) 'put)
(= 4 (length form))
(eq (car-safe (cadr form)) 'quote)
@@ -471,12 +472,12 @@ Return nil if there are no more forms, t otherwise."
(setq name 'cl-macs
file nil
elint-doing-cl t)) ; blech
- (setq env (elint-add-required-env env name file))))))
- env)
+ (setq elint-env (elint-add-required-env elint-env name file))))))
+ elint-env)
(defun elint-init-env (forms)
"Initialize the environment from FORMS."
- (let ((env (elint-make-env))
+ (let ((elint-env (elint-make-env))
form)
(while forms
(setq form (elint-top-form-form (car forms))
@@ -489,7 +490,7 @@ Return nil if there are no more forms, t otherwise."
with-no-warnings))
(mapc 'elint-init-form (cdr form))
(elint-init-form form)))
- env))
+ elint-env))
(defun elint-add-required-env (env name file)
"Augment ENV with the variables defined by feature NAME in FILE."
@@ -1171,5 +1172,4 @@ If no documentation could be found args will be `unknown'."
(provide 'elint)
-;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f
;;; elint.el ends here
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 216d91baa7b..9d59337a7c7 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -213,6 +213,8 @@ LIBRARY should be a string (the name of the library)."
(interactive
(let* ((dirs (or find-function-source-path load-path))
(suffixes (find-library-suffixes))
+ (table (apply-partially 'locate-file-completion-table
+ dirs suffixes))
(def (if (eq (function-called-at-point) 'require)
;; `function-called-at-point' may return 'require
;; with `point' anywhere on this line. So wrap the
@@ -226,16 +228,12 @@ LIBRARY should be a string (the name of the library)."
(thing-at-point 'symbol))
(error nil))
(thing-at-point 'symbol))))
- (when def
- (setq def (and (locate-file-completion-table
- dirs suffixes def nil 'lambda)
- def)))
+ (when (and def (not (test-completion def table)))
+ (setq def nil))
(list
(completing-read (if def (format "Library name (default %s): " def)
"Library name: ")
- (apply-partially 'locate-file-completion-table
- dirs suffixes)
- nil nil nil nil def))))
+ table nil nil nil nil def))))
(let ((buf (find-file-noselect (find-library-name library))))
(condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf)))))
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index f213d2dba9d..371fe8af3ad 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -1,7 +1,7 @@
;;; 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
@@ -26,15 +26,8 @@
;;; Code:
-;; Provide a meaningful error message if we are running on
-;; bare (non-float) emacs.
-
-(if (fboundp 'atan)
- nil
- (error "Floating point was disabled at compile time"))
-
-;; provide an easy hook to tell if we are running with floats or not.
-;; define pi and e via math-lib calls. (much less prone to killer typos.)
+;; Provide an easy hook to tell if we are running with floats or not.
+;; Define pi and e via math-lib calls (much less prone to killer typos).
(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")
@@ -45,7 +38,7 @@
(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 X from degrees to radians."
@@ -56,5 +49,4 @@
(provide 'lisp-float-type)
-;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d
;;; float-sup.el ends here
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index b4ac0eebf6d..c90d1394978 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -407,10 +407,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(if (and (buffer-modified-p)
(y-or-n-p (format "Save buffer %s first? " (buffer-name))))
(save-buffer))
- (let ((compiled-file-name (byte-compile-dest-file buffer-file-name)))
- (if (file-newer-than-file-p compiled-file-name buffer-file-name)
- (load-file compiled-file-name)
- (byte-compile-file buffer-file-name t))))
+ (byte-recompile-file buffer-file-name nil 0 t))
(defcustom emacs-lisp-mode-hook nil
"Hook run when entering Emacs Lisp mode."
@@ -1078,7 +1075,7 @@ is the buffer position of the start of the containing expression."
(goto-char calculate-lisp-indent-last-sexp)
(or (and (looking-at ":")
(setq indent (current-column)))
- (and (< (save-excursion (beginning-of-line) (point))
+ (and (< (line-beginning-position)
(prog2 (backward-sexp) (point)))
(looking-at ":")
(setq indent (current-column))))
@@ -1440,5 +1437,4 @@ means don't indent that line."
(provide 'lisp-mode)
-;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf
;;; lisp-mode.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 61a2985226d..fecddcf16ed 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -77,7 +77,7 @@
;; Other external functions you may want to use:
;;
-;; M-x package-list-packages
+;; M-x list-packages
;; Enters a mode similar to buffer-menu which lets you manage
;; packages. You can choose packages for install (mark with "i",
;; then "x" to execute) or deletion (not implemented yet), and you
@@ -215,7 +215,6 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")."
(declare-function url-http-parse-response "url-http" ())
(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/"))
@@ -278,9 +277,12 @@ contrast, `package-user-dir' contains packages for personal use."
;; until it's needed (i.e. when `package-intialize' is called).
(defvar package--builtins nil
"Alist of built-in packages.
+The actual value is initialized by loading the library
+`finder-inf'; this is not done until it is needed, e.g. by the
+function `package-built-in-p'.
+
Each element has the form (PKG . DESC), where PKG is a package
name (a symbol) and DESC is a vector that describes the package.
-
The vector DESC has the form [VERSION REQS DOCSTRING].
VERSION is a version list.
REQS is a list of packages (symbols) required by the package.
@@ -329,7 +331,9 @@ E.g., if given \"quux-23.0\", will return \"quux\""
(match-string 1 dirname)))
(defun package-load-descriptor (dir package)
- "Load the description file in directory DIR for package PACKAGE."
+ "Load the description file in directory DIR for package PACKAGE.
+Here, PACKAGE is a string of the form NAME-VER, where NAME is the
+package name and VER is its version."
(let* ((pkg-dir (expand-file-name package dir))
(pkg-file (expand-file-name
(concat (package-strip-version package) "-pkg")
@@ -387,8 +391,10 @@ updates `package-alist' and `package-obsolete-alist'."
"Extract the kind of download from an archive package description vector."
(aref desc 3))
-(defun package--dir (name version-string)
- (let* ((subdir (concat name "-" version-string))
+(defun package--dir (name version)
+ "Return the directory where a package is installed, or nil if none.
+NAME and VERSION are both strings."
+ (let* ((subdir (concat name "-" version))
(dir-list (cons package-user-dir package-directory-list))
pkg-dir)
(while dir-list
@@ -404,7 +410,7 @@ updates `package-alist' and `package-obsolete-alist'."
(version-str (package-version-join (package-desc-vers pkg-vec)))
(pkg-dir (package--dir name version-str)))
(unless pkg-dir
- (error "Internal error: could not find directory for %s-%s"
+ (error "Internal error: unable to find directory for `%s-%s'"
name version-str))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
@@ -419,42 +425,46 @@ updates `package-alist' and `package-obsolete-alist'."
;; Don't return nil.
t))
-(defun package--built-in (package version)
- "Return true if the package is built-in to Emacs."
+(defun package-built-in-p (package &optional version)
+ "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs."
+ (require 'finder-inf nil t) ; For `package--builtins'.
(let ((elt (assq package package--builtins)))
- (and elt (version-list-= (package-desc-vers (cdr elt)) version))))
+ (and elt (version-list-<= version (package-desc-vers (cdr elt))))))
-;; FIXME: return a reason instead?
+;; This function goes ahead and activates a newer version of a package
+;; if an older one was already activated. This is not ideal; we'd at
+;; least need to check to see if the package has actually been loaded,
+;; and not merely activated.
(defun package-activate (package version)
- "Activate a package, and recursively activate its dependencies.
+ "Activate package PACKAGE, of version VERSION or newer.
+If PACKAGE has any dependencies, recursively activate them.
Return nil if the package could not be activated."
- ;; Assume the user knows what he is doing -- go ahead and activate a
- ;; newer version of a package if an older one has already been
- ;; activated. This is not ideal; we'd at least need to check to see
- ;; if the package has actually been loaded, and not merely
- ;; activated. However, don't try to activate 'emacs', as that makes
- ;; no sense.
- (unless (eq package 'emacs)
- (let* ((pkg-desc (assq package package-alist))
- (this-version (package-desc-vers (cdr pkg-desc)))
- (req-list (package-desc-reqs (cdr pkg-desc)))
- ;; If the package was never activated, do it now.
- (keep-going (or (not (memq package package-activated-list))
- (version-list-< version this-version))))
- (while (and req-list keep-going)
- (let* ((req (car req-list))
- (req-name (car req))
- (req-version (cadr req)))
- (or (package-activate req-name req-version)
- (setq keep-going nil)))
- (setq req-list (cdr req-list)))
- (if keep-going
- (package-activate-1 package (cdr pkg-desc))
- ;; We get here if a dependency failed to activate -- but we
- ;; can also get here if the requested package was already
- ;; activated. Return non-nil in the latter case.
- (and (memq package package-activated-list)
- (version-list-<= version this-version))))))
+ (let ((pkg-vec (cdr (assq package package-alist)))
+ available-version found)
+ ;; Check if PACKAGE is available in `package-alist'.
+ (when pkg-vec
+ (setq available-version (package-desc-vers pkg-vec)
+ found (version-list-<= version available-version)))
+ (cond
+ ;; If no such package is found, maybe it's built-in.
+ ((null found)
+ (package-built-in-p package version))
+ ;; If the package is already activated, just return t.
+ ((memq package package-activated-list)
+ t)
+ ;; Otherwise, proceed with activation.
+ (t
+ (let ((fail (catch 'dep-failure
+ ;; Activate its dependencies recursively.
+ (dolist (req (package-desc-reqs pkg-vec))
+ (unless (package-activate (car req) (cadr req))
+ (throw 'dep-failure req))))))
+ (if fail
+ (warn "Unable to activate package `%s'.
+Required package `%s-%s' is unavailable"
+ package (car fail) (package-version-join (cadr fail)))
+ ;; If all goes well, activate the package itself.
+ (package-activate-1 package pkg-vec)))))))
(defun package-mark-obsolete (package pkg-vec)
"Put package on the obsolete list, if not already there."
@@ -470,48 +480,45 @@ Return nil if the package could not be activated."
pkg-vec)))
package-obsolete-alist))))
-(defun define-package (name-str version-string
+(defun define-package (name-string version-string
&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.
+NAME-STRING is the name of the package, as a string.
+VERSION-STRING is the version of the package, as a list of
+integers of the form produced by `version-to-list'.
+DOCSTRING is a short description of the package, a string.
+REQUIREMENTS is a list of dependencies on other packages.
Each requirement is of the form (OTHER-PACKAGE \"VERSION\").
EXTRA-PROPERTIES is currently unused."
- (let* ((name (intern name-str))
- (pkg-desc (assq name package-alist))
- (new-version (version-to-list version-string))
+ (let* ((name (intern name-string))
+ (version (version-to-list version-string))
(new-pkg-desc
(cons name
- (vector new-version
+ (vector version
(mapcar
(lambda (elt)
(list (car elt)
(version-to-list (car (cdr elt)))))
requirements)
- docstring))))
- ;; Only redefine a package if the redefinition is newer.
- (if (or (not pkg-desc)
- (version-list-< (package-desc-vers (cdr pkg-desc))
- new-version))
- (progn
- (when pkg-desc
- ;; Remove old package and declare it obsolete.
- (setq package-alist (delq pkg-desc package-alist))
- (package-mark-obsolete (car pkg-desc) (cdr pkg-desc)))
- ;; Add package to the 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.
- (unless (version-list-= new-version
- (package-desc-vers (cdr pkg-desc)))
- ;; The package is born obsolete.
- (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc))))))
+ docstring)))
+ (old-pkg (assq name package-alist)))
+ (cond
+ ;; If there's no old package, just add this to `package-alist'.
+ ((null old-pkg)
+ (push new-pkg-desc package-alist))
+ ((version-list-< (package-desc-vers (cdr old-pkg)) version)
+ ;; Remove the old package and declare it obsolete.
+ (package-mark-obsolete name (cdr old-pkg))
+ (setq package-alist (cons new-pkg-desc
+ (delq old-pkg package-alist))))
+ ;; You can have two packages with the same version, e.g. one in
+ ;; the system package directory and one in your private
+ ;; directory. We just let the first one win.
+ ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
+ ;; The package is born obsolete.
+ (package-mark-obsolete name (cdr new-pkg-desc))))))
;; From Emacs 22.
(defun package-autoload-ensure-default-file (file)
@@ -562,12 +569,8 @@ Otherwise it uses an external `tar' program.
(defun package-unpack (name version)
(let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
package-user-dir)))
- ;; Be careful!!
(make-directory package-user-dir t)
- (if (file-directory-p pkg-dir)
- (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're
- ; more confident
- (directory-files pkg-dir t "^[^.]")))
+ ;; FIXME: should we delete PKG-DIR if it exists?
(let* ((default-directory (file-name-as-directory package-user-dir)))
(package-untar-buffer)
(package-generate-autoloads (symbol-name name) pkg-dir)
@@ -605,7 +608,7 @@ Otherwise it uses an external `tar' program.
(mapcar
(lambda (elt)
(list (car elt)
- (package-version-join (car (cdr elt)))))
+ (package-version-join (cadr elt))))
requires))))
"\n")
nil
@@ -657,10 +660,14 @@ It will move point to somewhere in the headers."
(kill-buffer tar-buffer))))
(defun package-installed-p (package &optional min-version)
+ "Return true if PACKAGE, of VERSION or newer, is installed.
+Built-in packages also qualify."
(let ((pkg-desc (assq package package-alist)))
- (and pkg-desc
- (version-list-<= min-version
- (package-desc-vers (cdr pkg-desc))))))
+ (if pkg-desc
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc)))
+ ;; Also check built-in packages.
+ (package-built-in-p package min-version))))
(defun package-compute-transaction (package-list requirements)
"Return a list of packages to be installed, including PACKAGE-LIST.
@@ -691,17 +698,18 @@ not included in this list."
((null (stringp hold))
(error "Invalid element in `package-load-list'"))
((version-list-< (version-to-list hold) next-version)
- (error "Package '%s' held at version %s, \
+ (error "Package `%s' held at version %s, \
but version %s required"
(symbol-name next-pkg) hold
(package-version-join next-version)))))
(unless pkg-desc
- (error "Package '%s' is not available for installation"
- (symbol-name next-pkg)))
+ (error "Package `%s-%s' is unavailable"
+ (symbol-name next-pkg)
+ (package-version-join next-version)))
(unless (version-list-<= next-version
(package-desc-vers (cdr pkg-desc)))
(error
- "Need package '%s' with version %s, but only %s is available"
+ "Need package `%s-%s', but only %s is available"
(symbol-name next-pkg) (package-version-join next-version)
(package-version-join (package-desc-vers (cdr pkg-desc)))))
;; Only add to the transaction if we don't already have it.
@@ -745,6 +753,7 @@ Will throw an error if the archive version is too new."
(defun package-read-all-archive-contents ()
"Re-read `archive-contents', if it exists.
If successful, set `package-archive-contents'."
+ (setq package-archive-contents nil)
(dolist (archive package-archives)
(package-read-archive-contents (car archive))))
@@ -811,7 +820,7 @@ The package is found on one of the archives in `package-archives'."
nil t))))
(let ((pkg-desc (assq name package-archive-contents)))
(unless pkg-desc
- (error "Package '%s' is not available for installation"
+ (error "Package `%s' is not available for installation"
(symbol-name name)))
(package-download-transaction
(package-compute-transaction (list name)
@@ -968,11 +977,16 @@ The file can either be a tar file or an Emacs Lisp file."
(t (error "Unrecognized extension `%s'" (file-name-extension file))))))
(defun package-delete (name version)
- (require 'dired) ; for dired-delete-file
- (dired-delete-file (expand-file-name (concat name "-" version)
- package-user-dir)
- ;; FIXME: query user?
- 'always))
+ (let ((dir (package--dir name version)))
+ (if (string-equal (file-name-directory dir)
+ (file-name-as-directory
+ (expand-file-name package-user-dir)))
+ (progn
+ (delete-directory dir t t)
+ (message "Package `%s-%s' deleted." name version))
+ ;; Don't delete "system" packages
+ (error "Package `%s-%s' is a system package, not deleting"
+ name version))))
(defun package-archive-url (name)
"Return the archive containing the package NAME."
@@ -1014,21 +1028,22 @@ makes them available for download."
(car archive)))))
(package-read-all-archive-contents))
+(defvar package--initialized nil)
+
;;;###autoload
-(defun package-initialize ()
+(defun package-initialize (&optional no-activate)
"Load Emacs Lisp packages, and activate them.
-The variable `package-load-list' controls which packages to load."
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(interactive)
- (require 'finder-inf nil t)
- (setq package-alist package--builtins)
- (setq package-activated-list (mapcar #'car package-alist))
- (setq package-obsolete-alist nil)
+ (setq package-alist nil
+ package-obsolete-alist nil)
(package-load-all-descriptors)
(package-read-all-archive-contents)
- ;; Try to activate all our packages.
- (mapc (lambda (elt)
- (package-activate (car elt) (package-desc-vers (cdr elt))))
- package-alist))
+ (unless no-activate
+ (dolist (elt package-alist)
+ (package-activate (car elt) (package-desc-vers (cdr elt)))))
+ (setq package--initialized t))
;;;; Package description buffer.
@@ -1037,10 +1052,15 @@ The variable `package-load-list' controls which packages to load."
(defun describe-package (package)
"Display the full documentation of PACKAGE (a symbol)."
(interactive
- (let* ((packages (append (mapcar 'car package-alist)
- (mapcar 'car package-archive-contents)))
- (guess (function-called-at-point))
- val)
+ (let* ((guess (function-called-at-point))
+ packages val)
+ (require 'finder-inf nil t)
+ ;; Load the package list if necessary (but don't activate them).
+ (unless package--initialized
+ (package-initialize t))
+ (setq packages (append (mapcar 'car package-alist)
+ (mapcar 'car package-archive-contents)
+ (mapcar 'car package--builtins)))
(unless (memq guess packages)
(setq guess nil))
(setq packages (mapcar 'symbol-name packages))
@@ -1051,8 +1071,8 @@ The variable `package-load-list' controls which packages to load."
"Describe package: ")
packages nil t nil nil guess))
(list (if (equal val "") guess (intern val)))))
- (if (or (null package) (null (symbolp package)))
- (message "You did not specify a package")
+ (if (or (null package) (not (symbolp package)))
+ (message "No package specified")
(help-setup-xref (list #'describe-package package)
(called-interactively-p 'interactive))
(with-help-window (help-buffer)
@@ -1066,22 +1086,27 @@ The variable `package-load-list' controls which packages to load."
desc pkg-dir reqs version installable)
(prin1 package)
(princ " is ")
- (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))
+ (cond
+ ;; Loaded packages are in `package-alist'.
+ ((setq desc (cdr (assq package package-alist)))
+ (setq version (package-version-join (package-desc-vers desc)))
+ (if (setq pkg-dir (package--dir package-name version))
+ (insert "an installed package.\n\n")
+ ;; This normally does not happen.
+ (insert "a deleted package.\n\n")))
+ ;; Available packages are in `package-archive-contents'.
+ ((setq desc (cdr (assq package package-archive-contents)))
+ (setq version (package-version-join (package-desc-vers desc))
installable t)
- (insert "an uninstalled package.\n\n"))
+ (if built-in
+ (insert "a built-in package.\n\n")
+ (insert "an uninstalled package.\n\n")))
+ (built-in
+ (setq desc (cdr built-in)
+ version (package-version-join (package-desc-vers desc)))
+ (insert "a built-in package.\n\n"))
+ (t
+ (insert "an orphan package.\n\n")))
(insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
(cond (pkg-dir
@@ -1091,32 +1116,35 @@ The variable `package-load-list' controls which packages to load."
;; Todo: Add button for uninstalling.
(help-insert-xref-button (file-name-as-directory pkg-dir)
'help-package-def pkg-dir)
- (insert "'."))
+ (if built-in
+ (insert "',\n shadowing a "
+ (propertize "built-in package"
+ 'font-lock-face 'font-lock-builtin-face)
+ ".")
+ (insert "'.")))
(installable
- (insert "Available -- ")
- (let ((button-text (if (display-graphic-p)
- "Install"
- "[Install]"))
+ (if built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
+ " Alternate version available -- ")
+ (insert "Available -- "))
+ (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
(button-face (if (display-graphic-p)
'(:box (:line-width 2 :color "dark grey")
:background "light grey"
:foreground "black")
'link)))
- (insert-text-button button-text
- 'face button-face
- 'follow-link t
+ (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) "."))
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
(t (insert "Deleted.")))
(insert "\n")
- (and version
- (> (length version) 0)
+ (and version (> (length version) 0)
(insert " "
(propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
- (setq reqs (package-desc-reqs desc))
+
+ (setq reqs (if desc (package-desc-reqs desc)))
(when reqs
(insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
(let ((first t)
@@ -1134,9 +1162,9 @@ The variable `package-load-list' controls which packages to load."
(help-insert-xref-button text 'help-package name))
(insert "\n")))
(insert " " (propertize "Summary" 'font-lock-face 'bold)
- ": " (package-desc-doc desc) "\n\n")
+ ": " (if desc (package-desc-doc desc)) "\n\n")
- (if (assq package package--builtins)
+ (if built-in
;; For built-in packages, insert the commentary.
(let ((fn (locate-file (concat package-name ".el") load-path
load-file-rep-suffixes))
@@ -1187,7 +1215,7 @@ The variable `package-load-list' controls which packages to load."
(defvar package-menu-mode-map
(let ((map (make-keymap))
(menu-map (make-sparse-keymap "Package")))
- (suppress-keymap map)
+ (set-keymap-parent map button-buffer-map)
(define-key map "\C-m" 'package-menu-describe-package)
(define-key map "q" 'quit-window)
(define-key map "n" 'next-line)
@@ -1340,12 +1368,16 @@ buffers. The arguments are ignored."
(defun package-menu-mark-delete (num)
"Mark a package for deletion and move to the next line."
(interactive "p")
- (package-menu-mark-internal "D"))
+ (if (string-equal (package-menu-get-status) "installed")
+ (package-menu-mark-internal "D")
+ (forward-line)))
(defun package-menu-mark-install (num)
"Mark a package for installation and move to the next line."
(interactive "p")
- (package-menu-mark-internal "I"))
+ (if (string-equal (package-menu-get-status) "available")
+ (package-menu-mark-internal "I")
+ (forward-line)))
(defun package-menu-mark-unmark (num)
"Clear any marks on a package and move to the next line."
@@ -1399,34 +1431,58 @@ buffers. The arguments are ignored."
"")))
(defun package-menu-execute ()
- "Perform all the marked actions.
-Packages marked for installation will be downloaded and
-installed. Packages marked for deletion will be removed.
-Note that after installing packages you will want to restart
-Emacs."
+ "Perform marked Package Menu actions.
+Packages marked for installation are downloaded and installed;
+packages marked for deletion are removed."
(interactive)
- (goto-char (point-min))
- (while (not (eobp))
- (let ((cmd (char-after))
- (pkg-name (package-menu-get-package))
- (pkg-vers (package-menu-get-version))
- (pkg-status (package-menu-get-status)))
- (cond
- ((eq cmd ?D)
- (when (and (string= pkg-status "installed")
- (string= pkg-name "package"))
- ;; FIXME: actually, we could be tricky and remove all info.
- ;; But that is drastic and the user can do that instead.
- (error "Can't delete most recent version of `package'"))
- ;; Ask for confirmation here? Maybe if package status is ""?
- ;; Or if any lisp from package is actually loaded?
- (message "Deleting %s-%s..." pkg-name pkg-vers)
- (package-delete pkg-name pkg-vers)
- (message "Deleting %s-%s... done" pkg-name pkg-vers))
- ((eq cmd ?I)
- (package-install (intern pkg-name)))))
- (forward-line))
- (package-menu-revert))
+ (let (install-list delete-list cmd)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq cmd (char-after))
+ (cond
+ ((eq cmd ?\s) t)
+ ((eq cmd ?D)
+ (push (cons (package-menu-get-package)
+ (package-menu-get-version))
+ delete-list))
+ ((eq cmd ?I)
+ (push (package-menu-get-package) install-list)))
+ (forward-line)))
+ ;; Delete packages, prompting if necessary.
+ (when delete-list
+ (if (yes-or-no-p
+ (if (= (length delete-list) 1)
+ (format "Delete package `%s-%s'? "
+ (caar delete-list)
+ (cdr (car delete-list)))
+ (format "Delete these %d packages (%s)? "
+ (length delete-list)
+ (mapconcat (lambda (elt)
+ (concat (car elt) "-" (cdr elt)))
+ delete-list
+ ", "))))
+ (dolist (elt delete-list)
+ (condition-case err
+ (package-delete (car elt) (cdr elt))
+ (error (message (cadr err)))))
+ (error "Aborted")))
+ (when install-list
+ (if (yes-or-no-p
+ (if (= (length install-list) 1)
+ (format "Install package `%s'? " (car install-list))
+ (format "Install these %d packages (%s)? "
+ (length install-list)
+ (mapconcat 'identity install-list ", "))))
+ (dolist (elt install-list)
+ (package-install (intern elt)))))
+ ;; If we deleted anything, regenerate `package-alist'. This is done
+ ;; automatically if we installed a package.
+ (and delete-list (null install-list)
+ (package-initialize))
+ (if (or delete-list install-list)
+ (package-menu-revert)
+ (message "No operations specified."))))
(defun package-print-package (package version key desc)
(let ((face
@@ -1471,32 +1527,36 @@ A value of nil means to display all packages.")
(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)
;; 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)))
+ (when (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)))
+ hold (cadr (assq name package-load-list)))
(setq info-list
(package-list-maybe-add
name (package-desc-vers desc)
;; FIXME: it turns out to be tricky to see if this
;; package is presently activated.
- (cond ((stringp hold) "held")
- ((and builtin
- (version-list-=
- (package-desc-vers builtin)
- (package-desc-vers desc)))
- "built-in")
- (t "installed"))
+ (if (stringp hold) "held" "installed")
+ (package-desc-doc desc)
+ info-list))))
+
+ ;; List built-in packages
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (null package-menu-package-list)
+ (memq name package-menu-package-list)))
+ (setq desc (cdr elt))
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ "built-in"
(package-desc-doc desc)
info-list))))
@@ -1602,6 +1662,7 @@ A value of nil means to display all packages.")
"Generate and pop to the *Packages* buffer.
Optional PACKAGES is a list of names of packages (symbols) to
list; the default is to display everything in `package-alist'."
+ (require 'finder-inf nil t)
(with-current-buffer (get-buffer-create "*Packages*")
(package-menu-mode)
(set (make-local-variable 'package-menu-package-list) packages)
@@ -1618,6 +1679,9 @@ list; the default is to display everything in `package-alist'."
Fetches the updated list of packages before displaying.
The list is displayed in a buffer named `*Packages*'."
(interactive)
+ ;; Initialize the package system if necessary.
+ (unless package--initialized
+ (package-initialize t))
(package-refresh-contents)
(package--list-packages))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index b922e0b0233..5ff26b3dbc0 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -25,6 +25,16 @@
;; ML-style pattern matching.
;; The entry points are autoloaded.
+;; Todo:
+
+;; - provide ways to extend the set of primitives, with some kind of
+;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
+;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
+;; But better would be if we could define new ways to match by having the
+;; extension provide its own `pcase--split-<foo>' thingy.
+;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
+;; generate a lex-style DFA to decide whether to run E1 or E2.
+
;;; Code:
(eval-when-compile (require 'cl))
@@ -36,6 +46,8 @@
;; over and over again.
(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
+(defconst pcase--dontcare-upats '(t _ dontcare))
+
;;;###autoload
(defmacro pcase (exp &rest cases)
"Perform ML-style pattern matching on EXP.
@@ -48,10 +60,12 @@ UPatterns can take the following forms:
(and UPAT...) matches if all the patterns match.
`QPAT matches if the QPattern QPAT matches.
(pred PRED) matches if PRED applied to the object returns non-nil.
+ (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
QPatterns can take the following forms:
(QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
,UPAT matches if the UPattern UPAT matches.
+ STRING matches if the object is `equal' to STRING.
ATOM matches if the object is `eq' to ATOM.
QPatterns for vectors are not implemented yet.
@@ -63,38 +77,64 @@ PRED patterns can refer to variables bound earlier in the pattern.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
- (declare (indent 1) (debug case))
+ (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
(or (gethash (cons exp cases) pcase-memoize)
(puthash (cons exp cases)
- (pcase-expand exp cases)
+ (pcase--expand exp cases)
pcase-memoize)))
;;;###autoload
-(defmacro pcase-let* (bindings body)
+(defmacro pcase-let* (bindings &rest body)
"Like `let*' but where you can use `pcase' patterns for bindings.
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
- (if (null bindings) body
+ (declare (indent 1) (debug let))
+ (cond
+ ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
+ ((pcase--trivial-upat-p (caar bindings))
+ `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
+ (t
`(pcase ,(cadr (car bindings))
- (,(caar bindings) (pcase-let* ,(cdr bindings) ,body))
- (t (error "Pattern match failure in `pcase-let'")))))
+ (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
+ ;; We can either signal an error here, or just use `dontcare' which
+ ;; generates more efficient code. In practice, if we use `dontcare' we
+ ;; will still often get an error and the few cases where we don't do not
+ ;; matter that much, so it's a better choice.
+ (dontcare nil)))))
;;;###autoload
-(defmacro pcase-let (bindings body)
+(defmacro pcase-let (bindings &rest body)
"Like `let' but where you can use `pcase' patterns for bindings.
-BODY should be an expression, and BINDINGS should be a list of bindings
+BODY should be a list of expressions, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
+ (declare (indent 1) (debug let))
(if (null (cdr bindings))
- `(pcase-let* ,bindings ,body)
- (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings))
- `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding)))
- bindings)
- (pcase-let*
- ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding)))
- bindings)
- ,body))))
-
-(defun pcase-expand (exp cases)
+ `(pcase-let* ,bindings ,@body)
+ (let ((matches '()))
+ (dolist (binding (prog1 bindings (setq bindings nil)))
+ (cond
+ ((memq (car binding) pcase--dontcare-upats)
+ (push (cons (make-symbol "_") (cdr binding)) bindings))
+ ((pcase--trivial-upat-p (car binding)) (push binding bindings))
+ (t
+ (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
+ (push (cons tmpvar (cdr binding)) bindings)
+ (push (list (car binding) tmpvar) matches)))))
+ `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
+
+(defmacro pcase-dolist (spec &rest body)
+ (if (pcase--trivial-upat-p (car spec))
+ `(dolist ,spec ,@body)
+ (let ((tmpvar (make-symbol "x")))
+ `(dolist (,tmpvar ,@(cdr spec))
+ (pcase-let* ((,(car spec) ,tmpvar))
+ ,@body)))))
+
+
+(defun pcase--trivial-upat-p (upat)
+ (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
+
+(defun pcase--expand (exp cases)
(let* ((defs (if (symbolp exp) '()
(let ((sym (make-symbol "x")))
(prog1 `((,sym ,exp)) (setq exp sym)))))
@@ -137,23 +177,24 @@ of the form (UPAT EXP)."
(mapcar #'car vars)))
`(funcall ,res ,@args)))))))
(main
- (pcase-u
+ (pcase--u
(mapcar (lambda (case)
`((match ,exp . ,(car case))
,(apply-partially
- (if (pcase-small-branch-p (cdr case))
+ (if (pcase--small-branch-p (cdr case))
;; Don't bother sharing multiple
;; occurrences of this leaf since it's small.
#'pcase-codegen codegen)
(cdr case))))
cases))))
- `(let ,defs ,main)))
+ (if (null defs) main
+ `(let ,defs ,main))))
(defun pcase-codegen (code vars)
`(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
,@code))
-(defun pcase-small-branch-p (code)
+(defun pcase--small-branch-p (code)
(and (= 1 (length code))
(or (not (consp (car code)))
(let ((small t))
@@ -163,19 +204,26 @@ of the form (UPAT EXP)."
;; Try to use `cond' rather than a sequence of `if's, so as to reduce
;; the depth of the generated tree.
-(defun pcase-if (test then else)
+(defun pcase--if (test then else)
(cond
- ((eq else :pcase-dontcare) then)
+ ((eq else :pcase--dontcare) then)
((eq (car-safe else) 'if)
- `(cond (,test ,then)
- (,(nth 1 else) ,(nth 2 else))
- (t ,@(nthcdr 3 else))))
+ (if (equal test (nth 1 else))
+ ;; Doing a test a second time: get rid of the redundancy.
+ ;; FIXME: ideally, this should never happen because the pcase--split-*
+ ;; funs should have eliminated such things, but pcase--split-member
+ ;; is imprecise, so in practice it can happen occasionally.
+ `(if ,test ,then ,@(nthcdr 3 else))
+ `(cond (,test ,then)
+ (,(nth 1 else) ,(nth 2 else))
+ (t ,@(nthcdr 3 else)))))
((eq (car-safe else) 'cond)
`(cond (,test ,then)
- ,@(cdr else)))
+ ;; Doing a test a second time: get rid of the redundancy, as above.
+ ,@(remove (assoc test else) (cdr else))))
(t `(if ,test ,then ,else))))
-(defun pcase-upat (qpattern)
+(defun pcase--upat (qpattern)
(cond
((eq (car-safe qpattern) '\,) (cadr qpattern))
(t (list '\` qpattern))))
@@ -198,7 +246,7 @@ of the form (UPAT EXP)."
;; canonicalize them to one form over another, but we do occasionally
;; turn one into the other.
-(defun pcase-u (branches)
+(defun pcase--u (branches)
"Expand matcher for rules BRANCHES.
Each BRANCH has the form (MATCH CODE . VARS) where
CODE is the code generator for that branch.
@@ -209,12 +257,12 @@ MATCH is the pattern that needs to be matched, of the form:
(or MATCH ...)"
(when (setq branches (delq nil branches))
(destructuring-bind (match code &rest vars) (car branches)
- (pcase-u1 (list match) code vars (cdr branches)))))
+ (pcase--u1 (list match) code vars (cdr branches)))))
-(defun pcase-and (match matches)
+(defun pcase--and (match matches)
(if matches `(and ,match ,@matches) match))
-(defun pcase-split-match (sym splitter match)
+(defun pcase--split-match (sym splitter match)
(case (car match)
((match)
(if (not (eq sym (cadr match)))
@@ -223,20 +271,21 @@ MATCH is the pattern that needs to be matched, of the form:
(cond
;; Hoist `or' and `and' patterns to `or' and `and' matches.
((memq (car-safe pat) '(or and))
- (pcase-split-match sym splitter
- (cons (car pat)
- (mapcar (lambda (alt)
- `(match ,sym . ,alt))
- (cdr pat)))))
+ (pcase--split-match sym splitter
+ (cons (car pat)
+ (mapcar (lambda (alt)
+ `(match ,sym . ,alt))
+ (cdr pat)))))
(t (let ((res (funcall splitter (cddr match))))
(cons (or (car res) match) (or (cdr res) match))))))))
((or and)
(let ((then-alts '())
(else-alts '())
- (neutral-elem (if (eq 'or (car match)) :pcase-fail :pcase-succeed))
- (zero-elem (if (eq 'or (car match)) :pcase-succeed :pcase-fail)))
+ (neutral-elem (if (eq 'or (car match))
+ :pcase--fail :pcase--succeed))
+ (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
(dolist (alt (cdr match))
- (let ((split (pcase-split-match sym splitter alt)))
+ (let ((split (pcase--split-match sym splitter alt)))
(unless (eq (car split) neutral-elem)
(push (car split) then-alts))
(unless (eq (cdr split) neutral-elem)
@@ -251,50 +300,50 @@ MATCH is the pattern that needs to be matched, of the form:
(t (cons (car match) (nreverse else-alts)))))))
(t (error "Uknown MATCH %s" match))))
-(defun pcase-split-rest (sym splitter rest)
+(defun pcase--split-rest (sym splitter rest)
(let ((then-rest '())
(else-rest '()))
(dolist (branch rest)
(let* ((match (car branch))
(code&vars (cdr branch))
(splitted
- (pcase-split-match sym splitter match)))
- (unless (eq (car splitted) :pcase-fail)
+ (pcase--split-match sym splitter match)))
+ (unless (eq (car splitted) :pcase--fail)
(push (cons (car splitted) code&vars) then-rest))
- (unless (eq (cdr splitted) :pcase-fail)
+ (unless (eq (cdr splitted) :pcase--fail)
(push (cons (cdr splitted) code&vars) else-rest))))
(cons (nreverse then-rest) (nreverse else-rest))))
-(defun pcase-split-consp (syma symd pat)
+(defun pcase--split-consp (syma symd pat)
(cond
;; A QPattern for a cons, can only go the `then' side.
((and (eq (car-safe pat) '\`) (consp (cadr pat)))
(let ((qpat (cadr pat)))
- (cons `(and (match ,syma . ,(pcase-upat (car qpat)))
- (match ,symd . ,(pcase-upat (cdr qpat))))
- :pcase-fail)))
+ (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
+ (match ,symd . ,(pcase--upat (cdr qpat))))
+ :pcase--fail)))
;; A QPattern but not for a cons, can only go the `else' side.
- ((eq (car-safe pat) '\`) (cons :pcase-fail nil))))
+ ((eq (car-safe pat) '\`) (cons :pcase--fail nil))))
-(defun pcase-split-eq (elem pat)
+(defun pcase--split-equal (elem pat)
(cond
;; The same match will give the same result.
((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
- (cons :pcase-succeed :pcase-fail))
+ (cons :pcase--succeed :pcase--fail))
;; A different match will fail if this one succeeds.
((and (eq (car-safe pat) '\`)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
- (cons :pcase-fail nil))))
+ (cons :pcase--fail nil))))
-(defun pcase-split-memq (elems pat)
- ;; Based on pcase-split-eq.
+(defun pcase--split-member (elems pat)
+ ;; Based on pcase--split-equal.
(cond
- ;; The same match will give the same result, but we don't know how
- ;; to check it.
+ ;; The same match (or a match of membership in a superset) will
+ ;; give the same result, but we don't know how to check it.
;; (???
- ;; (cons :pcase-succeed nil))
+ ;; (cons :pcase--succeed nil))
;; A match for one of the elements may succeed or fail.
((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
nil)
@@ -303,26 +352,26 @@ MATCH is the pattern that needs to be matched, of the form:
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
- (cons :pcase-fail nil))))
+ (cons :pcase--fail nil))))
-(defun pcase-split-pred (upat pat)
+(defun pcase--split-pred (upat pat)
;; FIXME: For predicates like (pred (> a)), two such predicates may
;; actually refer to different variables `a'.
(if (equal upat pat)
- (cons :pcase-succeed :pcase-fail)))
+ (cons :pcase--succeed :pcase--fail)))
-(defun pcase-fgrep (vars sexp)
+(defun pcase--fgrep (vars sexp)
"Check which of the symbols VARS appear in SEXP."
(let ((res '()))
(while (consp sexp)
- (dolist (var (pcase-fgrep vars (pop sexp)))
+ (dolist (var (pcase--fgrep vars (pop sexp)))
(unless (memq var res) (push var res))))
(and (memq sexp vars) (not (memq sexp res)) (push sexp res))
res))
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
-(defun pcase-u1 (matches code vars rest)
+(defun pcase--u1 (matches code vars rest)
"Return code that runs CODE (with VARS) if MATCHES match.
and otherwise defers to REST which is a list of branches of the form
\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
@@ -333,11 +382,11 @@ and otherwise defers to REST which is a list of branches of the form
;; between matches. So we don't bother trying to reorder anything.
(cond
((null matches) (funcall code vars))
- ((eq :pcase-fail (car matches)) (pcase-u rest))
- ((eq :pcase-succeed (car matches))
- (pcase-u1 (cdr matches) code vars rest))
+ ((eq :pcase--fail (car matches)) (pcase--u rest))
+ ((eq :pcase--succeed (car matches))
+ (pcase--u1 (cdr matches) code vars rest))
((eq 'and (caar matches))
- (pcase-u1 (append (cdar matches) (cdr matches)) code vars rest))
+ (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
@@ -347,119 +396,126 @@ and otherwise defers to REST which is a list of branches of the form
(if (and (eq (car alt) 'match) (eq var (cadr alt))
(let ((upat (cddr alt)))
(and (eq (car-safe upat) '\`)
- (or (integerp (cadr upat)) (symbolp (cadr upat))))))
+ (or (integerp (cadr upat)) (symbolp (cadr upat))
+ (stringp (cadr upat))))))
(push (cddr alt) simples)
(push alt others))))
(cond
- ((null alts) (error "Please avoid it") (pcase-u rest))
+ ((null alts) (error "Please avoid it") (pcase--u rest))
((> (length simples) 1)
;; De-hoist the `or' MATCH into an `or' pattern that will be
;; turned into a `memq' below.
- (pcase-u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
- code vars
- (if (null others) rest
- (cons (list*
- (pcase-and (if (cdr others)
- (cons 'or (nreverse others))
- (car others))
- (cdr matches))
- code vars)
- rest))))
+ (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ code vars
+ (if (null others) rest
+ (cons (list*
+ (pcase--and (if (cdr others)
+ (cons 'or (nreverse others))
+ (car others))
+ (cdr matches))
+ code vars)
+ rest))))
(t
- (pcase-u1 (cons (pop alts) (cdr matches)) code vars
- (if (null alts) (progn (error "Please avoid it") rest)
- (cons (list*
- (pcase-and (if (cdr alts)
- (cons 'or alts) (car alts))
- (cdr matches))
- code vars)
- rest)))))))
+ (pcase--u1 (cons (pop alts) (cdr matches)) code vars
+ (if (null alts) (progn (error "Please avoid it") rest)
+ (cons (list*
+ (pcase--and (if (cdr alts)
+ (cons 'or alts) (car alts))
+ (cdr matches))
+ code vars)
+ rest)))))))
((eq 'match (caar matches))
(destructuring-bind (op sym &rest upat) (pop matches)
(cond
- ((memq upat '(t _)) (pcase-u1 matches code vars rest))
- ((eq upat 'dontcare) :pcase-dontcare)
+ ((memq upat '(t _)) (pcase--u1 matches code vars rest))
+ ((eq upat 'dontcare) :pcase--dontcare)
((functionp upat) (error "Feature removed, use (pred %s)" upat))
- ((eq (car-safe upat) 'pred)
+ ((memq (car-safe upat) '(guard pred))
(destructuring-bind (then-rest &rest else-rest)
- (pcase-split-rest
- sym (apply-partially 'pcase-split-pred upat) rest)
- (pcase-if (if (symbolp (cadr upat))
- `(,(cadr upat) ,sym)
- (let* ((exp (cadr upat))
- ;; `vs' is an upper bound on the vars we need.
- (vs (pcase-fgrep (mapcar #'car vars) exp))
- (call (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))))
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-pred upat) rest)
+ (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
+ `(,(cadr upat) ,sym)
+ (let* ((exp (cadr upat))
+ ;; `vs' is an upper bound on the vars we need.
+ (vs (pcase--fgrep (mapcar #'car vars) exp))
+ (call (cond
+ ((eq 'guard (car upat)) exp)
+ ((functionp exp) `(,exp ,sym))
+ (t `(,@exp ,sym)))))
+ (if (null vs)
+ call
+ ;; Let's not replace `vars' in `exp' since it's
+ ;; too difficult to do it right, instead just
+ ;; let-bind `vars' around `exp'.
+ `(let ,(mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs)
+ ;; FIXME: `vars' can capture `sym'. E.g.
+ ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
+ ,call))))
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
((symbolp upat)
- (pcase-u1 matches code (cons (cons upat sym) vars) rest))
+ (pcase--u1 matches code (cons (cons upat sym) vars) rest))
((eq (car-safe upat) '\`)
- (pcase-q1 sym (cadr upat) matches code vars rest))
+ (pcase--q1 sym (cadr upat) matches code vars rest))
((eq (car-safe upat) 'or)
- (let ((all (> (length (cdr upat)) 1)))
+ (let ((all (> (length (cdr upat)) 1))
+ (memq-fine t))
(when all
(dolist (alt (cdr upat))
(unless (and (eq (car-safe alt) '\`)
- (or (symbolp (cadr alt)) (integerp (cadr alt))))
+ (or (symbolp (cadr alt)) (integerp (cadr alt))
+ (setq memq-fine nil)
+ (stringp (cadr alt))))
(setq all nil))))
(if all
;; Use memq for (or `a `b `c `d) rather than a big tree.
(let ((elems (mapcar 'cadr (cdr upat))))
(destructuring-bind (then-rest &rest else-rest)
- (pcase-split-rest
- sym (apply-partially 'pcase-split-memq elems) rest)
- (pcase-if `(memq ,sym ',elems)
- (pcase-u1 matches code vars then-rest)
- (pcase-u else-rest))))
- (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
- (append (mapcar (lambda (upat)
- `((and (match ,sym . ,upat) ,@matches)
- ,code ,@vars))
- (cddr upat))
- rest)))))
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-member elems) rest)
+ (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
+ (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
+ (append (mapcar (lambda (upat)
+ `((and (match ,sym . ,upat) ,@matches)
+ ,code ,@vars))
+ (cddr upat))
+ rest)))))
((eq (car-safe upat) 'and)
- (pcase-u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat))
- matches)
- code vars rest))
+ (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
+ (cdr upat))
+ matches)
+ code vars rest))
((eq (car-safe upat) 'not)
;; FIXME: The implementation below is naive and results in
;; inefficient code.
- ;; To make it work right, we would need to turn pcase-u1's
+ ;; To make it work right, we would need to turn pcase--u1's
;; `code' and `vars' into a single argument of the same form as
;; `rest'. We would also need to split this new `then-rest' argument
;; for every test (currently we don't bother to do it since
;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
;; `(PAT3 . PAT4)) which the programmer can easily rewrite
;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
- (pcase-u1 `((match ,sym . ,(cadr upat)))
- (lexical-let ((rest rest))
- ;; FIXME: This codegen is not careful to share its
- ;; code if used several times: code blow up is likely.
- (lambda (vars)
- ;; `vars' will likely contain bindings which are
- ;; not always available in other paths to
- ;; `rest', so there' no point trying to pass
- ;; them down.
- (pcase-u rest)))
- vars
- (list `((and . ,matches) ,code . ,vars))))
+ (pcase--u1 `((match ,sym . ,(cadr upat)))
+ (lexical-let ((rest rest))
+ ;; FIXME: This codegen is not careful to share its
+ ;; code if used several times: code blow up is likely.
+ (lambda (vars)
+ ;; `vars' will likely contain bindings which are
+ ;; not always available in other paths to
+ ;; `rest', so there' no point trying to pass
+ ;; them down.
+ (pcase--u rest)))
+ vars
+ (list `((and . ,matches) ,code . ,vars))))
(t (error "Unknown upattern `%s'" upat)))))
(t (error "Incorrect MATCH %s" (car matches)))))
-(defun pcase-q1 (sym qpat matches code vars rest)
+(defun pcase--q1 (sym qpat matches code vars rest)
"Return code that runs CODE if SYM matches QPAT and if MATCHES match.
and if not, defers to REST which is a list of branches of the form
\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
@@ -473,22 +529,23 @@ and if not, defers to REST which is a list of branches of the form
(let ((syma (make-symbol "xcar"))
(symd (make-symbol "xcdr")))
(destructuring-bind (then-rest &rest else-rest)
- (pcase-split-rest sym (apply-partially 'pcase-split-consp syma symd)
- rest)
- (pcase-if `(consp ,sym)
- `(let ((,syma (car ,sym))
- (,symd (cdr ,sym)))
- ,(pcase-u1 `((match ,syma . ,(pcase-upat (car qpat)))
- (match ,symd . ,(pcase-upat (cdr qpat)))
- ,@matches)
- code vars then-rest))
- (pcase-u else-rest)))))
- ((or (integerp qpat) (symbolp qpat))
+ (pcase--split-rest sym
+ (apply-partially #'pcase--split-consp syma symd)
+ rest)
+ (pcase--if `(consp ,sym)
+ `(let ((,syma (car ,sym))
+ (,symd (cdr ,sym)))
+ ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
+ (match ,symd . ,(pcase--upat (cdr qpat)))
+ ,@matches)
+ code vars then-rest))
+ (pcase--u else-rest)))))
+ ((or (integerp qpat) (symbolp qpat) (stringp qpat))
(destructuring-bind (then-rest &rest else-rest)
- (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest)
- (pcase-if `(eq ,sym ',qpat)
- (pcase-u1 matches code vars then-rest)
- (pcase-u else-rest))))
+ (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)
+ (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
(t (error "Unkown QPattern %s" qpat))))
diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el
index 6389b62ea04..116d7b93d90 100644
--- a/lisp/emacs-lisp/regexp-opt.el
+++ b/lisp/emacs-lisp/regexp-opt.el
@@ -141,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.
@@ -239,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/smie.el b/lisp/emacs-lisp/smie.el
index 4f5b2046150..a7021b3cf7b 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -52,9 +52,9 @@
;; error because the parser just automatically does something. Better yet,
;; we can afford to use a sloppy grammar.
-;; The development (especially the parts building the 2D precedence
-;; tables and then computing the precedence levels from it) is largely
-;; inspired from page 187-194 of "Parsing techniques" by Dick Grune
+;; A good background to understand the development (especially the parts
+;; building the 2D precedence tables and then computing the precedence levels
+;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune
;; and Ceriel Jacobs (BookBody.pdf available at
;; http://www.cs.vu.nl/~dick/PTAPG.html).
;;
@@ -63,13 +63,36 @@
;; Since then, some of that code has been beaten into submission, but the
;; smie-indent-keyword is still pretty obscure.
-;;; Code:
+;; Conflict resolution:
+;;
+;; - One source of conflicts is when you have:
+;; (exp ("IF" exp "ELSE" exp "END") ("CASE" cases "END"))
+;; (cases (cases "ELSE" insts) ...)
+;; The IF-rule implies ELSE=END and the CASE-rule implies ELSE>END.
+;; FIXME: we could try to resolve such conflicts automatically by changing
+;; the way BNF rules such as the IF-rule is handled. I.e. rather than
+;; IF=ELSE and ELSE=END, we could turn them into IF<ELSE and ELSE>END
+;; and IF=END,
+
+;; TODO & BUGS:
+;;
+;; - Using the structural information SMIE gives us, it should be possible to
+;; implement a `smie-align' command that would automatically figure out what
+;; there is to align and how to do it (something like: align the token of
+;; lowest precedence that appears the same number of times on all lines,
+;; and then do the same on each side of that token).
+;; - Maybe accept two juxtaposed non-terminals in the BNF under the condition
+;; that the first always ends with a terminal, or that the second always
+;; starts with a terminal.
-;; FIXME: I think the behavior on empty lines is wrong. It shouldn't
-;; look at the next token on subsequent lines.
+;;; Code:
(eval-when-compile (require 'cl))
+(defgroup smie nil
+ "Simple Minded Indentation Engine."
+ :group 'languages)
+
(defvar comment-continue)
(declare-function comment-string-strip "newcomment" (str beforep afterp))
@@ -87,9 +110,9 @@
;; - 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
+;; - a precedence-level table (key word "grammar"), which is a alist
;; giving for each token its left and right precedence level (a
-;; number or nil). This is used in `smie-op-levels'.
+;; number or nil). This is used in `smie-grammar'.
;; 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
@@ -109,7 +132,8 @@
(display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y)))
(puthash key val table))))
-(defun smie-precs-precedence-table (precs)
+(put 'smie-precs->prec2 'pure t)
+(defun smie-precs->prec2 (precs)
"Compute a 2D precedence table from a list of precedences.
PRECS should be a list, sorted by precedence (e.g. \"+\" will
come before \"*\"), of elements of the form \(left OP ...)
@@ -132,6 +156,7 @@ one of those elements share the same precedence level and associativity."
(smie-set-prec2tab prec2-table other-op op op1)))))))
prec2-table))
+(put 'smie-merge-prec2s 'pure t)
(defun smie-merge-prec2s (&rest tables)
(if (null (cdr tables))
(car tables)
@@ -147,7 +172,13 @@ one of those elements share the same precedence level and associativity."
table))
prec2)))
-(defun smie-bnf-precedence-table (bnf &rest precs)
+(put 'smie-bnf->prec2 'pure t)
+(defun smie-bnf->prec2 (bnf &rest precs)
+ ;; FIXME: Add repetition operator like (repeat <separator> <elems>).
+ ;; Maybe also add (or <elem1> <elem2>...) for things like
+ ;; (exp (exp (or "+" "*" "=" ..) exp)).
+ ;; Basically, make it EBNF (except for the specification of a separator in
+ ;; the repetition).
(let ((nts (mapcar 'car bnf)) ;Non-terminals
(first-ops-table ())
(last-ops-table ())
@@ -155,7 +186,7 @@ one of those elements share the same precedence level and associativity."
(last-nts-table ())
(prec2 (make-hash-table :test 'equal))
(override (apply 'smie-merge-prec2s
- (mapcar 'smie-precs-precedence-table precs)))
+ (mapcar 'smie-precs->prec2 precs)))
again)
(dolist (rules bnf)
(let ((nt (car rules))
@@ -231,8 +262,9 @@ one of those elements share the same precedence level and associativity."
(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.
+ ;; precedence in smie-prec2->grammar.
(puthash :smie-open/close-alist (smie-bnf-classify bnf) prec2)
+ (puthash :smie-closer-alist (smie-bnf-closer-alist bnf) prec2)
prec2))
;; (defun smie-prec2-closer-alist (prec2 include-inners)
@@ -314,11 +346,12 @@ from the table, e.g. the table will not include things like (\"if\" . \"else\").
(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))
+ (nts (mapcar #'car bnf))
(alist '()))
(dolist (category bnf)
(puthash (car category) 'neither table) ;Remove non-terminals.
@@ -328,14 +361,22 @@ Each terminal can either be an `opener', a `closer', or neither."
(let ((first (pop rhs)))
(puthash first
(if (memq (gethash first table) '(nil opener))
- 'opener 'neither)
+ 'opener
+ (unless (member first nts)
+ (error "SMIE: token %s is both opener and non-opener"
+ first))
+ '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)
+ 'closer
+ (unless (member last nts)
+ (error "SMIE: token %s is both closer and non-closer"
+ last))
+ 'neither)
table)))))
(maphash (lambda (tok v)
(when (memq v '(closer opener))
@@ -359,7 +400,7 @@ CSTS is a list of pairs representing arcs in a graph."
(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)
@@ -377,16 +418,23 @@ CSTS is a list of pairs representing arcs in a graph."
(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:
- ;; - 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
- ;; bnf->prec function.
+;; (defun smie-check-grammar (grammar prec2 &optional dummy)
+;; (maphash (lambda (k v)
+;; (when (consp k)
+;; (let ((left (nth 2 (assoc (car k) grammar)))
+;; (right (nth 1 (assoc (cdr k) grammar))))
+;; (when (and left right)
+;; (cond
+;; ((< left right) (assert (eq v '<)))
+;; ((> left right) (assert (eq v '>)))
+;; (t (assert (eq v '=))))))))
+;; prec2))
+
+(put 'smie-prec2->grammar 'pure t)
+(defun smie-prec2->grammar (prec2)
"Take a 2D precedence table and turn it into an alist of precedence levels.
-PREC2 is a table as returned by `smie-precs-precedence-table' or
-`smie-bnf-precedence-table'."
+PREC2 is a table as returned by `smie-precs->prec2' or
+`smie-bnf->prec2'."
;; For each operator, we create two "variables" (corresponding to
;; the left and right precedence level), which are represented by
;; cons cells. Those are the very cons cells that appear in the
@@ -420,7 +468,7 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
(to (cdar eqs)))
(setq eqs (cdr eqs))
(if (eq to from)
- nil ;Nothing to do.
+ nil ;Nothing to do.
(dolist (other-eq eqs)
(if (eq from (cdr other-eq)) (setcdr other-eq to))
(when (eq from (car other-eq))
@@ -450,6 +498,7 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
;; left = right).
(unless (caar cst)
(setcar (car cst) i)
+ ;; (smie-check-grammar table prec2 'step1)
(incf i))
(setq csts (delq cst csts))))
(unless progress
@@ -459,37 +508,51 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or
(incf i 10))
;; Propagate equalities back to their source.
(dolist (eq (nreverse eqs))
- (assert (or (null (caar eq)) (eq (car eq) (cdr eq))))
- (setcar (car eq) (cadr eq)))
- ;; Finally, fill in the remaining vars (which only appeared on the
- ;; right side of the < constraints).
- (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.
+ (when (null (cadr eq))
+ ;; There's an equality constraint, but we still haven't given
+ ;; it a value: that means it binds tighter than anything else,
+ ;; and it can't be an opener/closer (those don't have equality
+ ;; constraints).
+ ;; So set it here rather than below since doing it below
+ ;; makes it more difficult to obey the equality constraints.
+ (setcar (cdr eq) i)
+ (incf i))
+ (assert (or (null (caar eq)) (eq (caar eq) (cadr eq))))
+ (setcar (car eq) (cadr eq))
+ ;; (smie-check-grammar table prec2 'step2)
+ )
+ ;; Finally, fill in the remaining vars (which did not appear on the
+ ;; left side of any < constraint).
+ (dolist (x table)
+ (unless (nth 1 x)
+ (setf (nth 1 x) i)
+ (incf i)) ;See other (incf i) above.
+ (unless (nth 2 x)
+ (setf (nth 2 x) i)
+ (incf i)))) ;See other (incf i) above.
+ ;; Mark closers and openers.
+ (dolist (x (gethash :smie-open/close-alist prec2))
+ (let* ((token (car x))
+ (cons (case (cdr x)
+ (closer (cddr (assoc token table)))
+ (opener (cdr (assoc token table))))))
+ (assert (numberp (car cons)))
+ (setf (car cons) (list (car cons)))))
+ (let ((ca (gethash :smie-closer-alist prec2)))
+ (when ca (push (cons :smie-closer-alist ca) table)))
+ ;; (smie-check-grammar table prec2 'step3)
table))
;;; Parsing using a precedence level table.
-(defvar smie-op-levels 'unset
+(defvar smie-grammar 'unset
"List of token parsing info.
+This list is normally built by `smie-prec2->grammar'.
Each element is of the form (TOKEN LEFT-LEVEL RIGHT-LEVEL).
Parsing is done using an operator precedence parser.
-LEFT-LEVEL and RIGHT-LEVEL can be either numbers or nil, where nil
+LEFT-LEVEL and RIGHT-LEVEL can be either numbers or a list, where a list
means that this operator does not bind on the corresponding side,
-i.e. a LEFT-LEVEL of nil means this is a token that behaves somewhat like
+e.g. a LEFT-LEVEL of nil means this is a token that behaves somewhat like
an open-paren, whereas a RIGHT-LEVEL of nil would correspond to something
like a close-paren.")
@@ -527,7 +590,7 @@ it should move backward to the beginning of the previous token.")
(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
+ ;; To distinguish the two cases, we made smie-prec2->grammar choose
;; different levels for each part of "if a then b else c", so that
;; by checking if the left-level is equal to the right level, we can
;; figure out that it's an associative operator.
@@ -545,6 +608,8 @@ OP-FORW is the accessor to the forward level of the level data.
OP-BACK is the accessor to the backward level of the level data.
HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
first token we see is an operator, skip over its left-hand-side argument.
+HALFSEXP can also be a token, in which case it means to parse as if
+we had just successfully passed this token.
Possible return values:
(FORW-LEVEL POS TOKEN): we couldn't skip TOKEN because its back-level
is too high. FORW-LEVEL is the forw-level of TOKEN,
@@ -553,11 +618,14 @@ Possible return values:
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
(catch 'return
- (let ((levels ()))
+ (let ((levels
+ (if (stringp halfsexp)
+ (prog1 (list (cdr (assoc halfsexp smie-grammar)))
+ (setq halfsexp nil)))))
(while
(let* ((pos (point))
(token (funcall next-token))
- (toklevels (cdr (assoc token smie-op-levels))))
+ (toklevels (cdr (assoc token smie-grammar))))
(cond
((null toklevels)
(when (zerop (length token))
@@ -573,9 +641,10 @@ Possible return values:
(if (eq pos (point))
;; We did not move, so let's abort the loop.
(throw 'return (list t (point))))))
- ((null (funcall op-back toklevels))
+ ((not (numberp (funcall op-back toklevels)))
;; A token like a paren-close.
- (assert (funcall op-forw toklevels)) ;Otherwise, why mention it?
+ (assert (numberp ; Otherwise, why mention it in smie-grammar.
+ (funcall op-forw toklevels)))
(push toklevels levels))
(t
(while (and levels (< (funcall op-back toklevels)
@@ -583,7 +652,7 @@ Possible return values:
(setq levels (cdr levels)))
(cond
((null levels)
- (if (and halfsexp (funcall op-forw toklevels))
+ (if (and halfsexp (numberp (funcall op-forw toklevels)))
(push toklevels levels)
(throw 'return
(prog1 (list (or (car toklevels) t) (point) token)
@@ -599,15 +668,15 @@ Possible return values:
;; Keep looking as long as we haven't matched the
;; topmost operator.
(levels
- (if (funcall op-forw toklevels)
+ (if (numberp (funcall op-forw toklevels))
(push toklevels levels)))
;; We matched the topmost operator. If the new operator
;; is the last in the corresponding BNF rule, we're done.
- ((null (funcall op-forw toklevels))
+ ((not (numberp (funcall op-forw toklevels)))
;; It is the last element, let's stop here.
(throw 'return (list nil (point) token)))
;; If the new operator is not the last in the BNF rule,
- ;; ans is not associative, it's one of the inner operators
+ ;; and 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))
(push toklevels levels))
@@ -630,6 +699,8 @@ Possible return values:
"Skip over one sexp.
HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
first token we see is an operator, skip over its left-hand-side argument.
+HALFSEXP can also be a token, in which case we should skip the text
+assuming it is the left-hand-side argument of that token.
Possible return values:
(LEFT-LEVEL POS TOKEN): we couldn't skip TOKEN because its right-level
is too high. LEFT-LEVEL is the left-level of TOKEN,
@@ -647,7 +718,9 @@ Possible return values:
(defun smie-forward-sexp (&optional halfsexp)
"Skip over one sexp.
HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
-first token we see is an operator, skip over its left-hand-side argument.
+first token we see is an operator, skip over its right-hand-side argument.
+HALFSEXP can also be a token, in which case we should skip the text
+assuming it is the right-hand-side argument of that token.
Possible return values:
(RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level
is too high. RIGHT-LEVEL is the right-level of TOKEN,
@@ -699,7 +772,7 @@ Possible return values:
(string (cdr (syntax-after (point))))
(let* ((open (funcall smie-forward-token-function))
(closer (cdr (assoc open smie-closer-alist)))
- (levels (list (assoc open smie-op-levels)))
+ (levels (list (assoc open smie-grammar)))
(seen '())
(found '()))
(cond
@@ -708,25 +781,23 @@ Possible return values:
;; intervention, e.g. for Octave's use of `until'
;; as a pseudo-closer of `do'.
(closer)
- ((or (equal levels '(nil)) (nth 1 (car levels)))
+ ((or (equal levels '(nil)) (numberp (nth 1 (car levels))))
(error "Doesn't look like a block"))
(t
- ;; FIXME: With grammars like Octave's, every closer ("end",
- ;; "endif", "endwhile", ...) has the same level, so we'd need
- ;; to look at the BNF or at least at the 2D prec-table, in
- ;; order to find the right closer for a given opener.
+ ;; Now that smie-setup automatically sets smie-closer-alist
+ ;; from the BNF, this is not really needed any more.
(while levels
(let ((level (pop levels)))
- (dolist (other smie-op-levels)
+ (dolist (other smie-grammar)
(when (and (eq (nth 2 level) (nth 1 other))
(not (memq other seen)))
(push other seen)
- (if (nth 2 other)
+ (if (numberp (nth 2 other))
(push other levels)
(push (car other) found))))))
(cond
((null found) (error "No known closer for opener %s" open))
- ;; FIXME: what should we do if there are various closers?
+ ;; What should we do if there are various closers?
(t (car found))))))))))
(unless (save-excursion (skip-chars-backward " \t") (bolp))
(newline))
@@ -752,7 +823,7 @@ This command assumes point is not in a string or comment."
(while
(let* ((pos (point))
(token (funcall next-token))
- (levels (assoc token smie-op-levels)))
+ (levels (assoc token smie-grammar)))
(cond
((zerop (length token))
(if (if (< inc 0) (looking-back "\\s(\\|\\s)" (1- (point)))
@@ -762,8 +833,8 @@ This command assumes point is not in a string or comment."
(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)))
+ ((and levels (not (numberp (nth (+ 1 offset) levels)))) nil)
+ ((and levels (not (numberp (nth (- 2 offset) levels))))
(let ((end (point)))
(goto-char start)
(signal 'scan-error
@@ -783,7 +854,8 @@ I.e. a good choice can be:
(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)
+ :type 'boolean
+ :group 'smie)
(defun smie-blink-matching-check (start end)
(save-excursion
@@ -803,14 +875,22 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"
(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)))
+ (let ((pos (point)) ;Position after the close token.
+ token)
+ (when (and blink-matching-paren
+ smie-closer-alist ; Optimization.
+ (or (eq (char-before) last-command-event) ;; Sanity check.
+ (save-excursion
+ (or (progn (skip-chars-backward " \t")
+ (setq pos (point))
+ (eq (char-before) last-command-event))
+ (progn (skip-chars-backward " \n\t")
+ (setq pos (point))
+ (eq (char-before) last-command-event)))))
+ (memq last-command-event smie-blink-matching-triggers)
+ (not (nth 8 (syntax-ppss))))
+ (save-excursion
+ (setq token (funcall smie-backward-token-function))
(when (and (eq (point) (1- pos))
(= 1 (length token))
(not (rassoc token smie-closer-alist)))
@@ -818,17 +898,20 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'.
;; 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))))
+ (setq token (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")
+ ;; Skip the trigger char, if applicable.
+ (if (eq (char-after) last-command-event)
+ (forward-char 1))
+ (if (eq ?\n last-command-event)
+ ;; Skip any auto-indentation, if applicable.
+ (skip-chars-forward " \t"))
(>= (point) pos))
- ;; If token ends with a trigger char, so don't blink for
+ ;; If token ends with a trigger char, 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.
@@ -836,7 +919,7 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'.
(not (memq (char-before)
smie-blink-matching-triggers)))
(or smie-blink-matching-inners
- (null (nth 2 (assoc token smie-op-levels)))))
+ (not (numberp (nth 2 (assoc token smie-grammar))))))
;; 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
@@ -848,192 +931,258 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'.
(defcustom smie-indent-basic 4
"Basic amount of indentation."
- :type 'integer)
-
-(defvar smie-indent-rules 'unset
- ;; TODO: For SML, we need more rule formats, so as to handle
- ;; structure Foo =
- ;; Bar (toto)
- ;; and
- ;; structure Foo =
- ;; struct ... end
- ;; I.e. the indentation after "=" depends on the parent ("structure")
- ;; as well as on the following token ("struct").
- "Rules of the following form.
-\((:before . TOK) . OFFSET-RULES) how to indent TOK itself.
-\(TOK . OFFSET-RULES) how to indent right after TOK.
-\(list-intro . TOKENS) declare TOKENS as being followed by what may look like
- a funcall but is just a sequence of expressions.
-\(t . OFFSET) basic indentation step.
-\(args . OFFSET) indentation of arguments.
-\((T1 . T2) OFFSET) like ((:before . T2) (:parent T1 OFFSET)).
-
-OFFSET-RULES is a list of elements which can each either be:
-
-\(:hanging . OFFSET-RULES) if TOK is hanging, use OFFSET-RULES.
-\(:parent PARENT . OFFSET-RULES) if TOK's parent is PARENT, use OFFSET-RULES.
-\(:next TOKEN . OFFSET-RULES) if TOK is followed by TOKEN, use OFFSET-RULES.
-\(:prev TOKEN . OFFSET-RULES) if TOK is preceded by TOKEN, use
-\(: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 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 an opening token defaults
-to `smie-indent-basic'.")
-
+ :type 'integer
+ :group 'smie)
+
+(defvar smie-rules-function 'ignore
+ "Function providing the indentation rules.
+It takes two arguments METHOD and ARG where the meaning of ARG
+and the expected return value depends on METHOD.
+METHOD can be:
+- :after, in which case ARG is a token and the function should return the
+ OFFSET to use for indentation after ARG.
+- :before, in which case ARG is a token and the function should return the
+ OFFSET to use to indent ARG itself.
+- :elem, in which case the function should return either:
+ - the offset to use to indent function arguments (ARG = `arg')
+ - the basic indentation step (ARG = `basic').
+- :list-intro, in which case ARG is a token and the function should return
+ non-nil if TOKEN is followed by a list of expressions (not separated by any
+ token) rather than an expression.
+
+When ARG is a token, the function is called with point just before that token.
+A return value of nil always means to fallback on the default behavior, so the
+function should return nil for arguments it does not expect.
+
+OFFSET can be:
+nil use the default indentation rule.
+`(column . COLUMN) indent to column COLUMN.
+NUMBER offset by NUMBER, relative to a base token
+ which is the current token for :after and
+ its parent for :before.
+
+The functions whose name starts with \"smie-rule-\" are helper functions
+designed specifically for use in this function.")
+
+(defalias 'smie-rule-hanging-p '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
- (when (zerop (length (funcall smie-forward-token-function)))
- ;; Could be an open-paren.
- (forward-char 1))
- (skip-chars-forward " \t")
- (eolp))
- (not (smie-indent--bolp))))
+ "Return non-nil if the current token is \"hanging\".
+A hanging keyword is one that's at the end of a line except it's not at
+the beginning of a line."
+ (and (not (smie-indent--bolp))
+ (save-excursion
+ (<= (line-end-position)
+ (progn
+ (when (zerop (length (funcall smie-forward-token-function)))
+ ;; Could be an open-paren.
+ (forward-char 1))
+ (skip-chars-forward " \t")
+ (or (eolp)
+ (and (looking-at comment-start-skip)
+ (forward-comment (point-max))))
+ (point))))))
+(defalias 'smie-rule-bolp 'smie-indent--bolp)
(defun smie-indent--bolp ()
+ "Return non-nil if the current token is the first on the line."
(save-excursion (skip-chars-backward " \t") (bolp)))
+;; Dynamically scoped.
+(defvar smie--parent) (defvar smie--after) (defvar smie--token)
+
+(defun smie-indent--parent ()
+ (or smie--parent
+ (save-excursion
+ (let* ((pos (point))
+ (tok (funcall smie-forward-token-function)))
+ (unless (numberp (cadr (assoc tok smie-grammar)))
+ (goto-char pos))
+ (setq smie--parent
+ (smie-backward-sexp 'halfsexp))))))
+
+(defun smie-rule-parent-p (&rest parents)
+ "Return non-nil if the current token's parent is among PARENTS.
+Only meaningful when called from within `smie-rules-function'."
+ (member (nth 2 (smie-indent--parent)) parents))
+
+(defun smie-rule-next-p (&rest tokens)
+ "Return non-nil if the next token is among TOKENS.
+Only meaningful when called from within `smie-rules-function'."
+ (let ((next
+ (save-excursion
+ (unless smie--after
+ (smie-indent-forward-token) (setq smie--after (point)))
+ (goto-char smie--after)
+ (smie-indent-forward-token))))
+ (member (car next) tokens)))
+
+(defun smie-rule-prev-p (&rest tokens)
+ "Return non-nil if the previous token is among TOKENS."
+ (let ((prev (save-excursion
+ (smie-indent-backward-token))))
+ (member (car prev) tokens)))
+
+(defun smie-rule-sibling-p ()
+ "Return non-nil if the parent is actually a sibling.
+Only meaningful when called from within `smie-rules-function'."
+ (eq (car (smie-indent--parent))
+ (cadr (assoc smie--token smie-grammar))))
+
+(defun smie-rule-parent (&optional offset)
+ "Align with parent.
+If non-nil, OFFSET should be an integer giving an additional offset to apply.
+Only meaningful when called from within `smie-rules-function'."
+ (save-excursion
+ (goto-char (cadr (smie-indent--parent)))
+ (cons 'column
+ (+ (or offset 0)
+ ;; Use smie-indent-virtual when indenting relative to an opener:
+ ;; this will also by default use current-column unless
+ ;; that opener is hanging, but will additionally consult
+ ;; rules-function, so it gives it a chance to tweak
+ ;; indentation (e.g. by forcing indentation relative to
+ ;; its own parent, as in fn a => fn b => fn c =>).
+ (if (or (listp (car smie--parent)) (smie-indent--hanging-p))
+ (smie-indent-virtual) (current-column))))))
+
+(defvar smie-rule-separator-outdent 2)
+
+(defun smie-indent--separator-outdent ()
+ ;; FIXME: Here we actually have several reasonable behaviors.
+ ;; E.g. for a parent token of "FOO" and a separator ";" we may want to:
+ ;; 1- left-align ; with FOO.
+ ;; 2- right-align ; with FOO.
+ ;; 3- align content after ; with content after FOO.
+ ;; 4- align content plus add/remove spaces so as to align ; with FOO.
+ ;; Currently, we try to align the contents (option 3) which actually behaves
+ ;; just like option 2 (if the number of spaces after FOO and ; is equal).
+ (let ((afterpos (save-excursion
+ (let ((tok (funcall smie-forward-token-function)))
+ (unless tok
+ (with-demoted-errors
+ (error "smie-rule-separator: can't skip token %s"
+ smie--token))))
+ (skip-chars-forward " ")
+ (unless (eolp) (point)))))
+ (or (and afterpos
+ ;; This should always be true, unless
+ ;; smie-forward-token-function skipped a \n.
+ (< afterpos (line-end-position))
+ (- afterpos (point)))
+ smie-rule-separator-outdent)))
+
+(defun smie-rule-separator (method)
+ "Indent current token as a \"separator\".
+By \"separator\", we mean here a token whose sole purpose is to separate
+various elements within some enclosing syntactic construct, and which does
+not have any semantic significance in itself (i.e. it would typically no exist
+as a node in an abstract syntax tree).
+Such a token is expected to have an associative syntax and be closely tied
+to its syntactic parent. Typical examples are \",\" in lists of arguments
+\(enclosed inside parentheses), or \";\" in sequences of instructions (enclosed
+in a {..} or begin..end block).
+METHOD should be the method name that was passed to `smie-rules-function'.
+Only meaningful when called from within `smie-rules-function'."
+ ;; FIXME: The code below works OK for cases where the separators
+ ;; are placed consistently always at beginning or always at the end,
+ ;; but not if some are at the beginning and others are at the end.
+ ;; I.e. it gets confused in cases such as:
+ ;; ( a
+ ;; , a,
+ ;; b
+ ;; , c,
+ ;; d
+ ;; )
+ ;;
+ ;; Assuming token is associative, the default rule for associative
+ ;; tokens (which assumes an infix operator) works fine for many cases.
+ ;; We mostly need to take care of the case where token is at beginning of
+ ;; line, in which case we want to align it with its enclosing parent.
+ (cond
+ ((and (eq method :before) (smie-rule-bolp) (not (smie-rule-sibling-p)))
+ (let ((parent-col (cdr (smie-rule-parent)))
+ (parent-pos-col ;FIXME: we knew this when computing smie--parent.
+ (save-excursion
+ (goto-char (cadr smie--parent))
+ (smie-indent-forward-token)
+ (forward-comment (point-max))
+ (current-column))))
+ (cons 'column
+ (max parent-col
+ (min parent-pos-col
+ (- parent-pos-col (smie-indent--separator-outdent)))))))
+ ((and (eq method :after) (smie-indent--bolp))
+ (smie-indent--separator-outdent))))
+
(defun smie-indent--offset (elem)
- (or (cdr (assq elem smie-indent-rules))
- (cdr (assq t smie-indent-rules))
+ (or (funcall smie-rules-function :elem elem)
+ (if (not (eq elem 'basic))
+ (funcall smie-rules-function :elem 'basic))
smie-indent-basic))
-(defvar smie-indent-debug-log)
-
-(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
-after the token, otherwise it should be nil.
-PARENT if non-nil should be the parent info returned by `smie-backward-sexp'."
- (let ((rules (cdr tokinfo))
- next prev
- offset)
- (while (consp rules)
- (let ((rule (pop rules)))
- (cond
- ((not (consp rule)) (setq offset rule))
- ((eq (car rule) '+) (setq offset rule))
- ((eq (car rule) :hanging)
- (when (smie-indent--hanging-p)
- (setq rules (cdr rule))))
- ((eq (car rule) :bolp)
- (when (smie-indent--bolp)
- (setq rules (cdr rule))))
- ((eq (car rule) :eolp)
- (unless after
- (error "Can't use :eolp in :before indentation rules"))
- (when (> after (line-end-position))
- (setq rules (cdr rule))))
- ((eq (car rule) :prev)
- (unless prev
- (save-excursion
- (setq prev (smie-indent-backward-token))))
- (when (equal (car prev) (cadr rule))
- (setq rules (cddr rule))))
- ((eq (car rule) :next)
- (unless next
- (unless after
- (error "Can't use :next in :before indentation rules"))
- (save-excursion
- (goto-char after)
- (setq next (smie-indent-forward-token))))
- (when (equal (car next) (cadr rule))
- (setq rules (cddr rule))))
- ((eq (car rule) :parent)
- (unless parent
- (save-excursion
- (if after (goto-char after))
- (setq parent (smie-backward-sexp 'halfsexp))))
- (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))))))
- ;; If `offset' is not set yet, use `rules' to handle the case where
- ;; the tokinfo uses the old-style ((PARENT . TOK). OFFSET).
- (unless offset (setq offset rules))
- (when (boundp 'smie-indent-debug-log)
- (push (list (point) offset tokinfo) smie-indent-debug-log))
- offset))
-
-(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))
- (cdr offset))))
- ((integerp offset)
- (+ offset
- (case base
- ((nil) 0)
- (parent (goto-char (cadr parent))
- (smie-indent-virtual))
- (t
- (goto-char base)
- ;; For indentation after "(let" in SML-mode, we end up accumulating
- ;; the offset of "(" and the offset of "let", so we use `min' to try
- ;; and get it right either way.
- (min (smie-indent-virtual) (current-column))))))
- ((eq offset 'point)
- ;; In indent-keyword, if we're indenting `then' wrt `if', we want to use
- ;; indent-virtual rather than use just current-column, so that we can
- ;; apply the (:before . "if") rule which does the "else if" dance in SML.
- ;; But in other cases, we do not want to use indent-virtual
- ;; (e.g. indentation of "*" w.r.t "+", or ";" wrt "("). We could just
- ;; always use indent-virtual and then have indent-rules say explicitly
- ;; to use `point' after things like "(" or "+" when they're not at EOL,
- ;; but you'd end up with lots of those rules.
- ;; So we use a heuristic here, which is that we only use virtual if
- ;; the parent is tightly linked to the child token (they're part of
- ;; the same BNF rule).
- (if (and virtual-point (null (car parent))) ;Black magic :-(
- (smie-indent-virtual) (current-column)))
- ((eq offset 'parent)
- (unless parent
- (setq parent (or (smie-backward-sexp 'halfsexp) :notfound)))
- (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--rule (method token
+ ;; FIXME: Too many parameters.
+ &optional after parent base-pos)
+ "Compute indentation column according to `indent-rule-functions'.
+METHOD and TOKEN are passed to `indent-rule-functions'.
+AFTER is the position after TOKEN, if known.
+PARENT is the parent info returned by `smie-backward-sexp', if known.
+BASE-POS is the position relative to which offsets should be applied."
+ ;; This is currently called in 3 cases:
+ ;; - :before opener, where rest=nil but base-pos could as well be parent.
+ ;; - :before other, where
+ ;; ; after=nil
+ ;; ; parent is set
+ ;; ; base-pos=parent
+ ;; - :after tok, where
+ ;; ; after is set; parent=nil; base-pos=point;
+ (save-excursion
+ (let ((offset
+ (let ((smie--parent parent)
+ (smie--token token)
+ (smie--after after))
+ (funcall smie-rules-function method token))))
+ (cond
+ ((not offset) nil)
+ ((eq (car-safe offset) 'column) (cdr offset))
+ ((integerp offset)
+ (+ offset
+ (if (null base-pos) 0
+ (goto-char base-pos)
+ ;; Use smie-indent-virtual when indenting relative to an opener:
+ ;; this will also by default use current-column unless
+ ;; that opener is hanging, but will additionally consult
+ ;; rules-function, so it gives it a chance to tweak indentation
+ ;; (e.g. by forcing indentation relative to its own parent, as in
+ ;; fn a => fn b => fn c =>).
+ ;; When parent==nil it doesn't matter because the only case
+ ;; where it's really used is when the base-pos is hanging anyway.
+ (if (or (and parent (null (car parent)))
+ (smie-indent--hanging-p))
+ (smie-indent-virtual) (current-column)))))
+ (t (error "Unknown indentation offset %s" offset))))))
(defun smie-indent-forward-token ()
"Skip token forward and return it, along with its levels."
(let ((tok (funcall smie-forward-token-function)))
(cond
- ((< 0 (length tok)) (assoc tok smie-op-levels))
- ((looking-at "\\s(")
+ ((< 0 (length tok)) (assoc tok smie-grammar))
+ ((looking-at "\\s(\\|\\s)\\(\\)")
(forward-char 1)
- (list (buffer-substring (1- (point)) (point)) nil 0)))))
+ (cons (buffer-substring (1- (point)) (point))
+ (if (match-end 1) '(0 nil) '(nil 0)))))))
(defun smie-indent-backward-token ()
"Skip token backward and return it, along with its levels."
- (let ((tok (funcall smie-backward-token-function)))
+ (let ((tok (funcall smie-backward-token-function))
+ class)
(cond
- ((< 0 (length tok)) (assoc tok smie-op-levels))
- ;; 4 == Open paren syntax.
- ((eq 4 (syntax-class (syntax-after (1- (point)))))
+ ((< 0 (length tok)) (assoc tok smie-grammar))
+ ;; 4 == open paren syntax, 5 == close.
+ ((memq (setq class (syntax-class (syntax-after (1- (point))))) '(4 5))
(forward-char -1)
- (list (buffer-substring (point) (1+ (point))) nil 0)))))
+ (cons (buffer-substring (point) (1+ (point)))
+ (if (eq class 4) '(nil 0) '(0 nil)))))))
(defun smie-indent-virtual ()
;; We used to take an optional arg (with value :not-hanging) to specify that
@@ -1079,54 +1228,48 @@ in order to figure out the indentation of some other (further down) point."
(smie-indent-virtual)) ;:not-hanging
(scan-error nil)))))
-(defun smie-indent-keyword ()
- ;; Align closing token with the corresponding opening one.
- ;; (e.g. "of" with "case", or "in" with "let").
+(defun smie-indent-keyword (&optional token)
+ "Indent point based on the token that follows it immediately.
+If TOKEN is non-nil, assume that that is the token that follows point.
+Returns either a column number or nil if it considers that indentation
+should not be computed on the basis of the following token."
(save-excursion
(let* ((pos (point))
- (toklevels (smie-indent-forward-token))
- (token (pop toklevels)))
- (if (null (car toklevels))
- (save-excursion
- (goto-char pos)
- ;; Different cases:
- ;; - 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-indent--bolp)
- ;; For an open-paren-like thingy at BOL, always indent only
- ;; based on other rules (typically smie-indent-after-keyword).
- nil)
- (t
- ;; We're only ever here for virtual-indent, which is why
- ;; we can use (current-column) as answer for `point'.
- (let* ((tokinfo (or (assoc (cons :before token)
- smie-indent-rules)
- ;; 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)))))
-
+ (toklevels
+ (if token
+ (assoc token smie-grammar)
+ (let* ((res (smie-indent-forward-token)))
+ ;; Ignore tokens on subsequent lines.
+ (if (and (< pos (line-beginning-position))
+ ;; Make sure `token' also *starts* on another line.
+ (save-excursion
+ (smie-indent-backward-token)
+ (< pos (line-beginning-position))))
+ nil
+ (goto-char pos)
+ res)))))
+ (setq token (pop toklevels))
+ (cond
+ ((null (cdr toklevels)) nil) ;Not a keyword.
+ ((not (numberp (car toklevels)))
+ ;; Different cases:
+ ;; - 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
+ ((smie-indent--rule :before token))
+ ((smie-indent--bolp) ;I.e. non-virtual indent.
+ ;; For an open-paren-like thingy at BOL, always indent only
+ ;; based on other rules (typically smie-indent-after-keyword).
+ nil)
+ (t
+ ;; By default use point unless we're hanging.
+ (unless (smie-indent--hanging-p) (current-column)))))
+ (t
;; FIXME: This still looks too much like black magic!!
- ;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we
- ;; want a single rule for TOKEN with different cases for each PARENT.
- (let* ((parent (smie-backward-sexp 'halfsexp))
- (tokinfo
- (or (assoc (cons (caddr parent) token)
- smie-indent-rules)
- (assoc (cons :before token) smie-indent-rules)
- ;; Default rule.
- `((:before . ,token)
- ;; (:parent open 0)
- point)))
- (offset (save-excursion
- (goto-char pos)
- (smie-indent--offset-rule tokinfo nil parent))))
+ (let* ((parent (smie-backward-sexp token)))
;; Different behaviors:
;; - align with parent.
;; - parent + offset.
@@ -1149,21 +1292,15 @@ in order to figure out the indentation of some other (further down) point."
;; maybe when an infix or close-paren is at the beginning
;; of a buffer.
nil)
+ ((save-excursion
+ (goto-char pos)
+ (smie-indent--rule :before token nil parent (cadr parent))))
((eq (car parent) (car toklevels))
- ;; We bumped into a same-level operator. align with it.
+ ;; We bumped into a same-level operator; align with it.
(if (and (smie-indent--bolp) (/= (point) pos)
(save-excursion
(goto-char (goto-char (cadr parent)))
- (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;
- ;; line2;
- ;; line3;
- ;; The ; on the first line had a special rule, but when
- ;; indenting line3, we don't care about it and want to
- ;; align with line2.
- (memq offset '(point nil)))
+ (not (smie-indent--bolp))))
;; If the parent is at EOL and its children are indented like
;; itself, then we can just obey the indentation chosen for the
;; child.
@@ -1190,19 +1327,27 @@ in order to figure out the indentation of some other (further down) point."
;; -> d
;; So as to align with the earliest appropriate place.
(smie-indent-virtual)))
- (tokinfo
- (if (and (= (point) pos) (smie-indent--bolp)
- (or (eq offset 'point)
- (and (consp offset) (memq 'point offset))))
+ (t
+ (if (and (= (point) pos) (smie-indent--bolp))
;; Since we started at BOL, we're not computing a virtual
;; indentation, and we're still at the starting point, so
;; we can't use `current-column' which would cause
- ;; indentation to depend on itself.
+ ;; indentation to depend on itself and we can't use
+ ;; smie-indent-virtual since that would be an inf-loop.
nil
- (smie-indent--column offset 'parent parent
- ;; If we're still at pos, indent-virtual
- ;; will inf-loop.
- (unless (= (point) pos) 'virtual))))))))))
+ ;; In indent-keyword, if we're indenting `then' wrt `if', we
+ ;; want to use indent-virtual rather than use just
+ ;; current-column, so that we can apply the (:before . "if")
+ ;; rule which does the "else if" dance in SML. But in other
+ ;; cases, we do not want to use indent-virtual (e.g. indentation
+ ;; of "*" w.r.t "+", or ";" wrt "("). We could just always use
+ ;; indent-virtual and then have indent-rules say explicitly to
+ ;; use `point' after things like "(" or "+" when they're not at
+ ;; EOL, but you'd end up with lots of those rules.
+ ;; So we use a heuristic here, which is that we only use virtual
+ ;; if the parent is tightly linked to the child token (they're
+ ;; part of the same BNF rule).
+ (if (car parent) (current-column) (smie-indent-virtual)))))))))))
(defun smie-indent-comment ()
"Compute indentation of a comment."
@@ -1240,10 +1385,19 @@ in order to figure out the indentation of some other (further down) point."
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))))
+ (let ((end (match-string 0)))
+ (and (nth 4 (syntax-ppss))
+ (save-excursion
+ (goto-char (nth 8 (syntax-ppss)))
+ (and (looking-at comment-start-skip)
+ (let ((start (match-string 0)))
+ ;; Align the common substring between starter
+ ;; and ender, if possible.
+ (if (string-match "\\(.+\\).*\n\\(.*?\\)\\1"
+ (concat start "\n" end))
+ (+ (current-column) (match-beginning 0)
+ (- (match-beginning 2) (match-end 2)))
+ (current-column)))))))))
(defun smie-indent-comment-inside ()
(and (nth 4 (syntax-ppss))
@@ -1254,27 +1408,18 @@ in order to figure out the indentation of some other (further down) point."
(save-excursion
(let* ((pos (point))
(toklevel (smie-indent-backward-token))
- (tok (car toklevel))
- (tokinfo (assoc tok smie-indent-rules)))
- ;; Set some default indent rules.
- (if (and toklevel (null (cadr toklevel)) (null tokinfo))
- (setq tokinfo (list (car toklevel))))
- ;; (if (and tokinfo (null toklevel))
- ;; (error "Token %S has indent rule but has no parsing info" tok))
- (when toklevel
- (unless tokinfo
- ;; The default indentation after a keyword/operator is 0 for
- ;; infix and t for prefix.
- ;; 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)))))
- (let ((offset
- (or (smie-indent--offset-rule tokinfo pos)
- (smie-indent--offset t))))
- (let ((before (point)))
- (goto-char pos)
- (smie-indent--column offset before)))))))
+ (tok (car toklevel)))
+ (cond
+ ((null toklevel) nil)
+ ((smie-indent--rule :after tok pos nil (point)))
+ ;; The default indentation after a keyword/operator is
+ ;; 0 for infix, t for prefix, and use another rule
+ ;; for postfix.
+ ((not (numberp (nth 2 toklevel))) nil) ;A closer.
+ ((or (not (numberp (nth 1 toklevel))) ;An opener.
+ (rassoc tok smie-closer-alist)) ;An inner.
+ (+ (smie-indent-virtual) (smie-indent--offset 'basic))) ;
+ (t (smie-indent-virtual)))))) ;An infix.
(defun smie-indent-exps ()
;; Indentation of sequences of simple expressions without
@@ -1301,9 +1446,10 @@ in order to figure out the indentation of some other (further down) point."
(save-excursion
;; Figure out if the atom we just skipped is an argument rather
;; than a function.
- (setq arg (or (null (car (smie-backward-sexp)))
- (member (funcall smie-backward-token-function)
- (cdr (assoc 'list-intro smie-indent-rules))))))
+ (setq arg
+ (or (null (car (smie-backward-sexp)))
+ (funcall smie-rules-function :list-intro
+ (funcall smie-backward-token-function)))))
(cond
((null positions)
;; We're the first expression of the list. In that case, the
@@ -1322,7 +1468,6 @@ in order to figure out the indentation of some other (further down) point."
(positions
;; We're the first arg.
(goto-char (car positions))
- ;; 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
@@ -1331,9 +1476,9 @@ in order to figure out the indentation of some other (further down) point."
(defvar smie-indent-functions
'(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)
+ 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
@@ -1347,13 +1492,13 @@ to which that point should be aligned, if we were to reindent it.")
"Indent current line using the SMIE indentation engine."
(interactive)
(let* ((savep (point))
- (indent (condition-case-no-debug nil
- (save-excursion
- (forward-line 0)
- (skip-chars-forward " \t")
- (if (>= (point) savep) (setq savep nil))
- (or (smie-indent-calculate) 0))
- (error 0))))
+ (indent (or (with-demoted-errors
+ (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " \t")
+ (if (>= (point) savep) (setq savep nil))
+ (or (smie-indent-calculate) 0)))
+ 0)))
(if (not (numberp indent))
;; If something funny is used (e.g. `noindent'), return it.
indent
@@ -1362,18 +1507,51 @@ to which that point should be aligned, if we were to reindent it.")
(save-excursion (indent-line-to indent))
(indent-line-to indent)))))
-(defun smie-indent-debug ()
- "Show the rules used to compute indentation of current line."
- (interactive)
- (let ((smie-indent-debug-log '()))
- (smie-indent-calculate)
- ;; FIXME: please improve!
- (message "%S" smie-indent-debug-log)))
-
-(defun smie-setup (op-levels indent-rules)
- (set (make-local-variable 'smie-indent-rules) indent-rules)
- (set (make-local-variable 'smie-op-levels) op-levels)
- (set (make-local-variable 'indent-line-function) 'smie-indent-line))
+(defun smie-setup (grammar rules-function &rest keywords)
+ "Setup SMIE navigation and indentation.
+GRAMMAR is a grammar table generated by `smie-prec2->grammar'.
+RULES-FUNCTION is a set of indentation rules for use on `smie-rules-function'.
+KEYWORDS are additional arguments, which can use the following keywords:
+- :forward-token FUN
+- :backward-token FUN"
+ (set (make-local-variable 'smie-rules-function) rules-function)
+ (set (make-local-variable 'smie-grammar) grammar)
+ (set (make-local-variable 'indent-line-function) 'smie-indent-line)
+ (set (make-local-variable 'forward-sexp-function)
+ 'smie-forward-sexp-command)
+ (while keywords
+ (let ((k (pop keywords))
+ (v (pop keywords)))
+ (case k
+ (:forward-token
+ (set (make-local-variable 'smie-forward-token-function) v))
+ (:backward-token
+ (set (make-local-variable 'smie-backward-token-function) v))
+ (t (message "smie-setup: ignoring unknown keyword %s" k)))))
+ (let ((ca (cdr (assq :smie-closer-alist grammar))))
+ (when ca
+ (set (make-local-variable 'smie-closer-alist) ca)
+ ;; Only needed for interactive calls to blink-matching-open.
+ (set (make-local-variable 'blink-matching-check-function)
+ #'smie-blink-matching-check)
+ (add-hook 'post-self-insert-hook
+ #'smie-blink-matching-open 'append 'local)
+ (set (make-local-variable 'smie-blink-matching-triggers)
+ (append smie-blink-matching-triggers
+ ;; Rather than wait for SPC to blink, try to blink as
+ ;; soon as we type the last char of a block ender.
+ (let ((closers (sort (mapcar #'cdr smie-closer-alist)
+ #'string-lessp))
+ (triggers ())
+ closer)
+ (while (setq closer (pop closers))
+ (unless (and closers
+ ;; FIXME: this eliminates prefixes of other
+ ;; closers, but we should probably elimnate
+ ;; prefixes of other keywords as well.
+ (string-prefix-p closer (car closers)))
+ (push (aref closer (1- (length closer))) triggers)))
+ (delete-dups triggers)))))))
(provide 'smie)
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 6ae6a86857e..b12d9068676 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -93,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.
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-22 06:05:15 +0000