summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
authorMiles Bader <miles@gnu.org>2004-06-28 07:56:49 +0000
committerMiles Bader <miles@gnu.org>2004-06-28 07:56:49 +0000
commit1ec1f46d8bb0aadcd9b2352a50f0d474fd5335d7 (patch)
treed0a8b52c066bd8ba411fa1585eef63540760444d /lisp/emacs-lisp
parenta1b8bed3e834b5232fd2cf4bfbe1d0bc2ee4680a (diff)
parent817e73c0bf35c607568db56649c631ef3a696b25 (diff)
downloademacs-1ec1f46d8bb0aadcd9b2352a50f0d474fd5335d7.tar.gz
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-15
Merge from emacs--cvs-trunk--0 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-218 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-220 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-221 Restore deleted tagline in etc/TUTORIAL.ru * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-222 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-228 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-229 Remove TeX output files from the archive * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-230 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-247 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-248 src/lisp.h (CYCLE_CHECK): Macro moved from xfaces.c * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-249 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-256 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-258 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-263 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-264 Update from CVS: lispref/display.texi: emacs -> Emacs. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-265 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-274 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-275 Update from CVS: man/makefile.w32-in: Revert last change * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-276 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-295 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-296 Allow restarting an existing debugger session that's exited * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-297 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-299 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-300 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-327 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-328 Update from CVS: src/.gdbinit (xsymbol): Fix last change. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-329 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-344 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-345 Tweak source regexps so that building in place won't cause problems * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-346 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-351 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-352 Update from CVS: lisp/flymake.el: New file. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-353 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-361 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-362 Support " [...]" style defaults in minibuffer-electric-default-mode * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-363 (read-number): Use canonical format for default in prompt. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-364 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-367 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-368 Improve display-supports-face-attributes-p on non-ttys * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-369 Rewrite face-differs-from-default-p * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-370 Move `display-supports-face-attributes-p' entirely into C code * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-371 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-372 Simplify face-differs-from-default-p; don't consider :stipple. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-373 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-374 (tty_supports_face_attributes_p): Ensure attributes differ from default * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-375 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-376 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-377 (Fdisplay_supports_face_attributes_p): Work around bootstrapping problem * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-378 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-380 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-381 Face merging cleanups * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-382 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-384 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-385 src/xfaces.c (push_named_merge_point): Return 0 if a cycle is detected * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-386 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-395 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-396 Tweak arch tagging to make build/install-in-place less annoying * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-397 Work around vc-arch problems when building eshell * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-398 Tweak permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-399 Tweak directory permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-400 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-401 More build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-402 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-403 Yet more build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-404 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-409 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-410 Make sure image types are initialized for lookup too * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-411 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-416 Update from CVS
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/autoload.el12
-rw-r--r--lisp/emacs-lisp/byte-run.el23
-rw-r--r--lisp/emacs-lisp/bytecomp.el82
-rw-r--r--lisp/emacs-lisp/checkdoc.el86
-rw-r--r--lisp/emacs-lisp/cl-indent.el8
-rw-r--r--lisp/emacs-lisp/cl-macs.el28
-rw-r--r--lisp/emacs-lisp/disass.el4
-rw-r--r--lisp/emacs-lisp/easymenu.el4
-rw-r--r--lisp/emacs-lisp/edebug.el16
-rw-r--r--lisp/emacs-lisp/ewoc.el51
-rw-r--r--lisp/emacs-lisp/find-func.el41
-rw-r--r--lisp/emacs-lisp/lisp-mode.el49
-rw-r--r--lisp/emacs-lisp/lisp.el163
-rw-r--r--lisp/emacs-lisp/pp.el56
-rw-r--r--lisp/emacs-lisp/re-builder.el2
-rw-r--r--lisp/emacs-lisp/rx.el421
-rw-r--r--lisp/emacs-lisp/timer.el13
17 files changed, 675 insertions, 384 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 43da3d09827..21843c9601d 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,6 +1,6 @@
;; autoload.el --- maintain autoloads in loaddefs.el
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2003
+;; Copyright (C) 1991,92,93,94,95,96,97, 2001,02,03,04
;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
@@ -407,7 +407,7 @@ Return FILE if there was no autoload cookie in it."
(if (and (or (null existing-buffer)
(not (buffer-modified-p existing-buffer)))
(listp last-time) (= (length last-time) 2)
- (not (autoload-before-p last-time file-time)))
+ (not (time-less-p last-time file-time)))
(progn
(if (interactive-p)
(message "\
@@ -468,11 +468,6 @@ Autoload section for %s is up to date."
(if no-autoloads file))))
-(defun autoload-before-p (time1 time2)
- (or (< (car time1) (car time2))
- (and (= (car time1) (car time2))
- (< (nth 1 time1) (nth 1 time2)))))
-
(defun autoload-remove-section (begin)
(goto-char begin)
(search-forward generate-autoload-section-trailer)
@@ -527,8 +522,7 @@ directory or directories specified."
(dolist (file file)
(let ((file-time (nth 5 (file-attributes file))))
(when (and file-time
- (not (autoload-before-p last-time
- file-time)))
+ (not (time-less-p last-time file-time)))
;; file unchanged
(push file no-autoloads)
(setq files (delete file files)))))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 9956d5003cc..2cd0896c835 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -76,21 +76,21 @@
(eval-and-compile
(put ',name 'byte-optimizer 'byte-compile-inline-expand))))
-(defun make-obsolete (fn new &optional when)
+(defun make-obsolete (function new &optional when)
"Make the byte-compiler warn that FUNCTION is obsolete.
The warning will say that NEW should be used instead.
If NEW is a string, that is the `use instead' message.
If provided, WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
- (let ((handler (get fn 'byte-compile)))
+ (let ((handler (get function 'byte-compile)))
(if (eq 'byte-compile-obsolete handler)
- (setq handler (nth 1 (get fn 'byte-obsolete-info)))
- (put fn 'byte-compile 'byte-compile-obsolete))
- (put fn 'byte-obsolete-info (list new handler when)))
- fn)
+ (setq handler (nth 1 (get function 'byte-obsolete-info)))
+ (put function 'byte-compile 'byte-compile-obsolete))
+ (put function 'byte-obsolete-info (list new handler when)))
+ function)
-(defun make-obsolete-variable (var new &optional when)
+(defun make-obsolete-variable (variable new &optional when)
"Make the byte-compiler warn that VARIABLE is obsolete.
The warning will say that NEW should be used instead.
If NEW is a string, that is the `use instead' message.
@@ -102,8 +102,8 @@ was first made obsolete, for example a date or a release number."
(if (equal str "") (error ""))
(intern str))
(car (read-from-string (read-string "Obsoletion replacement: ")))))
- (put var 'byte-obsolete-variable (cons new when))
- var)
+ (put variable 'byte-obsolete-variable (cons new when))
+ variable)
(put 'dont-compile 'lisp-indent-hook 0)
(defmacro dont-compile (&rest body)
@@ -134,11 +134,10 @@ The result of the body appears to the compiler as a quoted constant."
;; Remember, it's magic.
(cons 'progn body))
-(defun with-no-warnings (&optional first &rest body)
+(defun with-no-warnings (&rest body)
"Like `progn', but prevents compiler warnings in the body."
;; The implementation for the interpreter is basically trivial.
- (if body (car (last body))
- first))
+ (car (last body)))
;;; I nuked this because it's not a good idea for users to think of using it.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 3e3bfe2a074..c1a43722415 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -832,24 +832,22 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Log something that isn't a warning.
(defmacro byte-compile-log (format-string &rest args)
- (list 'and
- 'byte-optimize
- '(memq byte-optimize-log '(t source))
- (list 'let '((print-escape-newlines t)
- (print-level 4)
- (print-length 4))
- (list 'byte-compile-log-1
- (cons 'format
- (cons format-string
- (mapcar
- (lambda (x)
- (if (symbolp x) (list 'prin1-to-string x) x))
- args)))))))
+ `(and
+ byte-optimize
+ (memq byte-optimize-log '(t source))
+ (let ((print-escape-newlines t)
+ (print-level 4)
+ (print-length 4))
+ (byte-compile-log-1
+ (format
+ ,format-string
+ ,@(mapcar
+ (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x))
+ args))))))
;; Log something that isn't a warning.
(defun byte-compile-log-1 (string)
- (save-excursion
- (byte-goto-log-buffer)
+ (with-current-buffer "*Compile-Log*"
(goto-char (point-max))
(byte-compile-warning-prefix nil nil)
(cond (noninteractive
@@ -903,11 +901,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defvar byte-compile-last-warned-form nil)
(defvar byte-compile-last-logged-file nil)
-(defun byte-goto-log-buffer ()
- (set-buffer (get-buffer-create "*Compile-Log*"))
- (unless (eq major-mode 'compilation-mode)
- (compilation-mode)))
-
;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
@@ -983,6 +976,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Do this after setting default-directory.
(unless (eq major-mode 'compilation-mode)
(compilation-mode))
+ (compilation-forget-errors)
pt))))
;; Log a message STRING in *Compile-Log*.
@@ -1014,11 +1008,11 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(when (nth 2 new)))
(byte-compile-set-symbol-position (car form))
(if (memq 'obsolete byte-compile-warnings)
- (byte-compile-warn "%s is an obsolete function%s; %s" (car form)
+ (byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
(if when (concat " since " when) "")
(if (stringp (car new))
(car new)
- (format "use %s instead." (car new)))))
+ (format "use `%s' instead." (car new)))))
(funcall (or handler 'byte-compile-normal-call) form)))
;; Compiler options
@@ -2082,7 +2076,7 @@ list that represents a doc string reference.
(defun byte-compile-file-form-defsubst (form)
(when (assq (nth 1 form) byte-compile-unresolved-functions)
(setq byte-compile-current-form (nth 1 form))
- (byte-compile-warn "defsubst %s was used before it was defined"
+ (byte-compile-warn "defsubst `%s' was used before it was defined"
(nth 1 form)))
(byte-compile-file-form
(macroexpand form byte-compile-macro-environment))
@@ -2212,7 +2206,7 @@ list that represents a doc string reference.
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
(byte-compile-warn
- "%s defined multiple times, as both function and macro"
+ "`%s' defined multiple times, as both function and macro"
(nth 1 form)))
(setcdr that-one nil))
(this-one
@@ -2221,14 +2215,14 @@ list that represents a doc string reference.
;; byte-compiler macros in byte-run.el...
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
- (byte-compile-warn "%s %s defined multiple times in this file"
+ (byte-compile-warn "%s `%s' defined multiple times in this file"
(if macrop "macro" "function")
(nth 1 form))))
((and (fboundp name)
(eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
(when (memq 'redefine byte-compile-warnings)
- (byte-compile-warn "%s %s being redefined as a %s"
+ (byte-compile-warn "%s `%s' being redefined as a %s"
(if macrop "function" "macro")
(nth 1 form)
(if macrop "macro" "function")))
@@ -2701,7 +2695,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(handler (get fn 'byte-compile)))
(byte-compile-set-symbol-position fn)
(when (byte-compile-const-symbol-p fn)
- (byte-compile-warn "%s called as a function" fn))
+ (byte-compile-warn "`%s' called as a function" fn))
(if (and handler
(or (not (byte-compile-version-cond
byte-compile-compatibility))
@@ -2736,9 +2730,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (or (not (symbolp var))
(byte-compile-const-symbol-p var (not (eq base-op 'byte-varref))))
(byte-compile-warn
- (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s %s")
- ((eq base-op 'byte-varset) "variable assignment to %s %s")
- (t "variable reference to %s %s"))
+ (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
+ ((eq base-op 'byte-varset) "variable assignment to %s `%s'")
+ (t "variable reference to %s `%s'"))
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
@@ -2746,11 +2740,11 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
- (byte-compile-warn "%s is an obsolete variable%s; %s" var
+ (byte-compile-warn "`%s' is an obsolete variable%s; %s" var
(if when (concat " since " when) "")
(if (stringp (car ob))
(car ob)
- (format "use %s instead." (car ob))))))
+ (format "use `%s' instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind)
(push var byte-compile-bound-variables)
@@ -2759,11 +2753,11 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (eq base-op 'byte-varset)
(or (memq var byte-compile-free-assignments)
(progn
- (byte-compile-warn "assignment to free variable %s" var)
+ (byte-compile-warn "assignment to free variable `%s'" var)
(push var byte-compile-free-assignments)))
(or (memq var byte-compile-free-references)
(progn
- (byte-compile-warn "reference to free variable %s" var)
+ (byte-compile-warn "reference to free variable `%s'" var)
(push var byte-compile-free-references))))))))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
@@ -2964,7 +2958,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(defun byte-compile-subr-wrong-args (form n)
(byte-compile-set-symbol-position (car form))
- (byte-compile-warn "%s called with %d arg%s, but requires %s"
+ (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
(car form) (length (cdr form))
(if (= 1 (length (cdr form))) "" "s") n)
;; get run-time wrong-number-of-args error.
@@ -3130,7 +3124,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (and (consp (car body))
(not (eq 'byte-code (car (car body)))))
(byte-compile-warn
- "A quoted lambda form is the second argument of fset. This is probably
+ "A quoted lambda form is the second argument of `fset'. This is probably
not what you want, as that lambda cannot be compiled. Consider using
the syntax (function (lambda (...) ...)) instead.")))))
(byte-compile-two-args form))
@@ -3515,7 +3509,7 @@ being undefined will be suppressed."
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
(byte-compile-warn
- "%s is not a variable-name or nil (in condition-case)" var))
+ "`%s' is not a variable-name or nil (in condition-case)" var))
(byte-compile-push-constant var)
(byte-compile-push-constant (byte-compile-top-level
(nth 2 form) for-effect))
@@ -3533,13 +3527,13 @@ being undefined will be suppressed."
(setq syms (cdr syms)))
ok))))
(byte-compile-warn
- "%s is not a condition name or list of such (in condition-case)"
+ "`%s' is not a condition name or list of such (in condition-case)"
(prin1-to-string condition)))
;; ((not (or (eq condition 't)
;; (and (stringp (get condition 'error-message))
;; (consp (get condition 'error-conditions)))))
;; (byte-compile-warn
-;; "%s is not a known condition name (in condition-case)"
+;; "`%s' is not a known condition name (in condition-case)"
;; condition))
)
(setq compiled-clauses
@@ -3635,7 +3629,7 @@ being undefined will be suppressed."
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
(byte-compile-warn
- "%s called with %d argument%s, but %s %s"
+ "`%s' called with %d argument%s, but %s %s"
fun ncall
(if (= 1 ncall) "" "s")
(if (< ncall 2) "requires" "accepts only")
@@ -3652,7 +3646,7 @@ being undefined will be suppressed."
`(push ',var current-load-list))
(when (> (length form) 3)
(when (and string (not (stringp string)))
- (byte-compile-warn "third arg to %s %s is not a string: %s"
+ (byte-compile-warn "third arg to `%s %s' is not a string: %s"
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cddr form) ; `value' provided
@@ -3718,7 +3712,7 @@ being undefined will be suppressed."
(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
(defun byte-compile-no-warnings (form)
(let (byte-compile-warnings)
- (byte-compile-form (cadr form))))
+ (byte-compile-form (cons 'progn (cdr form)))))
;;; tags
@@ -3993,7 +3987,7 @@ already up-to-date."
nil))))
;;;###autoload
-(defun batch-byte-recompile-directory ()
+(defun batch-byte-recompile-directory (&optional arg)
"Run `byte-recompile-directory' on the dirs remaining on the command line.
Must be used only with `-batch', and kills Emacs on completion.
For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
@@ -4004,7 +3998,7 @@ For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
(or command-line-args-left
(setq command-line-args-left '(".")))
(while command-line-args-left
- (byte-recompile-directory (car command-line-args-left))
+ (byte-recompile-directory (car command-line-args-left) arg)
(setq command-line-args-left (cdr command-line-args-left)))
(kill-emacs 0))
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index fddab94dfd4..2aba3ea254c 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -1246,7 +1246,7 @@ generating a buffered list of errors."
With prefix ARG, turn Checkdoc minor mode on iff ARG is positive.
In Checkdoc minor mode, the usual bindings for `eval-defun' which is
-bound to \\<checkdoc-minor-mode-map> \\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
+bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
checking of documentation strings.
\\{checkdoc-minor-mode-map}"
@@ -2579,86 +2579,52 @@ This function will not modify `match-data'."
;;; Warning management
;;
(defvar checkdoc-output-font-lock-keywords
- '(("\\(\\w+\\.el\\): \\(\\w+\\)"
+ '(("^\\*\\*\\* \\(.+\\.el\\): \\([^ \n]+\\)"
(1 font-lock-function-name-face)
- (2 font-lock-comment-face))
- ("^\\(\\w+\\.el\\):" 1 font-lock-function-name-face)
- (":\\([0-9]+\\):" 1 font-lock-constant-face))
+ (2 font-lock-comment-face)))
"Keywords used to highlight a checkdoc diagnostic buffer.")
-(defvar checkdoc-output-mode-map nil
- "Keymap used in `checkdoc-output-mode'.")
+(defvar checkdoc-output-error-regex-alist
+ '(("^\\(.+\\.el\\):\\([0-9]+\\): " 1 2)))
(defvar checkdoc-pending-errors nil
"Non-nil when there are errors that have not been displayed yet.")
-(if checkdoc-output-mode-map
- nil
- (setq checkdoc-output-mode-map (make-sparse-keymap))
- (if (not (string-match "XEmacs" emacs-version))
- (define-key checkdoc-output-mode-map [mouse-2]
- 'checkdoc-find-error))
- (define-key checkdoc-output-mode-map "\C-c\C-c" 'checkdoc-find-error)
- (define-key checkdoc-output-mode-map "\C-m" 'checkdoc-find-error))
-
-(defun checkdoc-output-mode ()
- "Create and setup the buffer used to maintain checkdoc warnings.
-\\<checkdoc-output-mode-map>\\[checkdoc-find-error] - Go to this error location."
- (if (get-buffer checkdoc-diagnostic-buffer)
- (get-buffer checkdoc-diagnostic-buffer)
- (save-excursion
- (set-buffer (get-buffer-create checkdoc-diagnostic-buffer))
- (kill-all-local-variables)
- (setq mode-name "Checkdoc"
- major-mode 'checkdoc-output-mode)
- (set (make-local-variable 'font-lock-defaults)
- '((checkdoc-output-font-lock-keywords) t t ((?- . "w") (?_ . "w"))))
- (use-local-map checkdoc-output-mode-map)
- (run-hooks 'checkdoc-output-mode-hook)
- (current-buffer))))
-
-(defalias 'checkdoc-find-error-mouse 'checkdoc-find-error)
-(defun checkdoc-find-error (&optional event)
- "In a checkdoc diagnostic buffer, find the error under point."
- (interactive (list last-input-event))
- (if event (posn-set-point (event-end e)))
- (beginning-of-line)
- (if (looking-at "\\(\\(\\w+\\|\\s_\\)+\\.el\\):\\([0-9]+\\):")
- (let ((l (string-to-int (match-string 3)))
- (f (match-string 1)))
- (if (not (get-file-buffer f))
- (error "Can't find buffer %s" f))
- (switch-to-buffer-other-window (get-file-buffer f))
- (goto-line l))))
+(define-derived-mode checkdoc-output-mode compilation-mode "Checkdoc"
+ "Set up the major mode for the buffer containing the list of errors."
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ checkdoc-output-error-regex-alist)
+ (set (make-local-variable 'compilation-mode-font-lock-keywords)
+ checkdoc-output-font-lock-keywords))
(defun checkdoc-buffer-label ()
"The name to use for a checkdoc buffer in the error list."
(if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
+ (file-relative-name (buffer-file-name))
(concat "#<buffer "(buffer-name) ">")))
(defun checkdoc-start-section (check-type)
"Initialize the checkdoc diagnostic buffer for a pass.
Create the header so that the string CHECK-TYPE is displayed as the
function called to create the messages."
- (checkdoc-output-to-error-buffer
- "\n\n\C-l\n*** "
- (checkdoc-buffer-label) ": " check-type " V " checkdoc-version))
+ (let ((dir default-directory)
+ (label (checkdoc-buffer-label)))
+ (with-current-buffer (get-buffer-create checkdoc-diagnostic-buffer)
+ (checkdoc-output-mode)
+ (setq default-directory dir)
+ (goto-char (point-max))
+ (insert "\n\n\C-l\n*** " label ": " check-type " V " checkdoc-version))))
(defun checkdoc-error (point msg)
"Store POINT and MSG as errors in the checkdoc diagnostic buffer."
(setq checkdoc-pending-errors t)
- (checkdoc-output-to-error-buffer
- "\n" (checkdoc-buffer-label) ":"
- (int-to-string (count-lines (point-min) (or point (point-min)))) ": "
- msg))
-
-(defun checkdoc-output-to-error-buffer (&rest text)
- "Place TEXT into the checkdoc diagnostic buffer."
- (save-excursion
- (set-buffer (checkdoc-output-mode))
- (goto-char (point-max))
- (apply 'insert text)))
+ (let ((text (list "\n" (checkdoc-buffer-label) ":"
+ (int-to-string
+ (count-lines (point-min) (or point (point-min))))
+ ": " msg)))
+ (with-current-buffer (get-buffer checkdoc-diagnostic-buffer)
+ (goto-char (point-max))
+ (apply 'insert text))))
(defun checkdoc-show-diagnostics ()
"Display the checkdoc diagnostic buffer in a temporary window."
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index 2e6265d4dfd..c5e13a4c00f 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -216,8 +216,12 @@ If nil, indent backquoted lists as data, i.e., like quoted lists."
(cond ((string-match "\\`def"
function)
(setq tentative-defun t))
- ((string-match "\\`\\(with\\|do\\)-"
- function)
+ ((string-match
+ (eval-when-compile
+ (concat "\\`\\("
+ (regexp-opt '("with" "without" "do"))
+ "\\)-"))
+ function)
(setq method '(&lambda &body))))))
;; backwards compatibility. Bletch.
((eq method 'defun)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c61c275f2b0..68f823b88f3 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -164,21 +164,21 @@
;;; Symbols.
(defvar *gensym-counter*)
-(defun gensym (&optional arg)
+(defun gensym (&optional prefix)
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
- (num (if (integerp arg) arg
+ (let ((pfix (if (stringp prefix) prefix "G"))
+ (num (if (integerp prefix) prefix
(prog1 *gensym-counter*
(setq *gensym-counter* (1+ *gensym-counter*))))))
- (make-symbol (format "%s%d" prefix num))))
+ (make-symbol (format "%s%d" pfix num))))
-(defun gentemp (&optional arg)
+(defun gentemp (&optional prefix)
"Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
+ (let ((pfix (if (stringp prefix) prefix "G"))
name)
- (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
+ (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
(setq *gensym-counter* (1+ *gensym-counter*)))
(intern name)))
@@ -1177,12 +1177,14 @@ Valid clauses are:
(defmacro do (steps endtest &rest body)
"The Common Lisp `do' loop.
-Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+
+\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(cl-expand-do-loop steps endtest body nil))
(defmacro do* (steps endtest &rest body)
"The Common Lisp `do*' loop.
-Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+
+\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(cl-expand-do-loop steps endtest body t))
(defun cl-expand-do-loop (steps endtest body star)
@@ -2398,10 +2400,10 @@ The type name can then be used in `typecase', `check-type', etc."
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
-(defun typep (val type) ; See compiler macro below.
+(defun typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
- (eval (cl-make-type-test 'val type)))
+ (eval (cl-make-type-test 'object type)))
(defmacro check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
@@ -2438,8 +2440,8 @@ omitted, a default message listing FORM itself is used."
nil))))
(defmacro ignore-errors (&rest body)
- "Execute FORMS; if an error occurs, return nil.
-Otherwise, return result of last FORM."
+ "Execute BODY; if an error occurs, return nil.
+Otherwise, return result of last form in BODY."
`(condition-case nil (progn ,@body) (error nil)))
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index d8890bd0239..ed632b14cd4 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -4,7 +4,7 @@
;; Author: Doug Cutting <doug@csli.stanford.edu>
;; Jamie Zawinski <jwz@lucid.com>
-;; Maintainer: Jamie Zawinski <jwz@lucid.com>
+;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
@@ -57,7 +57,7 @@ redefine OBJECT if it is a symbol."
(interactive (list (intern (completing-read "Disassemble function: "
obarray 'fboundp t))
nil 0 t))
- (if (consp object)
+ (if (and (consp object) (not (eq (car object) 'lambda)))
(setq object (list 'lambda () object)))
(or indent (setq indent 0)) ;Default indent to zero
(save-excursion
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 88f7657b6bf..dbd7194f50a 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -478,8 +478,8 @@ Do it only if `easy-menu-precalculate-equivalent-keybindings' is on."
(when easy-menu-precalculate-equivalent-keybindings
(if (and (symbolp menu) (not (keymapp menu)) (boundp menu))
(setq menu (symbol-value menu)))
- ;; x-popup-menu does not exist on tty-only Emacs.
- ;; (if (keymapp menu) (x-popup-menu nil menu))
+ (and (keymapp menu) (fboundp 'x-popup-menu)
+ (x-popup-menu nil menu))
))
(defun add-submenu (menu-path submenu &optional before in-menu)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 8a924d045f7..9a7b9efc333 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -477,7 +477,8 @@ also dependent on the values of `edebug-all-defs' and
If the current defun is actually a call to `defvar', then reset the
variable using its initial value expression even if the variable
already has some other value. (Normally `defvar' does not change the
-variable's value if it already has a value.)
+variable's value if it already has a value.) Treat `defcustom'
+similarly. Reinitialize the face according to `defface' specification.
With a prefix argument, instrument the code for Edebug.
@@ -507,7 +508,12 @@ the minibuffer."
((and (eq (car form) 'defcustom)
(default-boundp (nth 1 form)))
;; Force variable to be bound.
- (set-default (nth 1 form) (eval (nth 2 form)))))
+ (set-default (nth 1 form) (eval (nth 2 form))))
+ ((eq (car form) 'defface)
+ ;; Reset the face.
+ (put (nth 1 form) 'face-defface-spec nil)
+ (setq face-new-frame-defaults
+ (assq-delete-all (nth 1 form) face-new-frame-defaults))))
(setq edebug-result (eval form))
(if (not edebugging)
(princ edebug-result)
@@ -3692,8 +3698,7 @@ Return the result of the last expression."
(setq edebug-previous-result
(concat "Result: "
(edebug-safe-prin1-to-string edebug-previous-value)
- (let ((name (prin1-char edebug-previous-value)))
- (if name (concat " = " name))))))
+ (eval-expression-print-format edebug-previous-value))))
(defun edebug-previous-result ()
"Print the previous result."
@@ -3712,7 +3717,8 @@ Print result in minibuffer."
(princ
(edebug-outside-excursion
(setq values (cons (edebug-eval edebug-expr) values))
- (edebug-safe-prin1-to-string (car values)))))
+ (concat (edebug-safe-prin1-to-string (car values))
+ (eval-expression-print-format (car values))))))
(defun edebug-eval-last-sexp ()
"Evaluate sexp before point in the outside environment; value in minibuffer."
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index a0c2e3c0d70..a2cb4e9fe46 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -1,6 +1,7 @@
;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer
-;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation
+;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 04
+;; Free Software Foundation
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
@@ -244,7 +245,7 @@ BUT if it is the header or the footer in EWOC return nil instead."
(defun ewoc--create-node (data pretty-printer pos)
"Call PRETTY-PRINTER with point set at POS in current buffer.
-Remember the start position. Create a wrapper containing that
+Remember the start position. Create a wrapper containing that
start position and the element DATA."
(save-excursion
;; Remember the position as a number so that it doesn't move
@@ -263,7 +264,7 @@ start position and the element DATA."
(defun ewoc--delete-node-internal (ewoc node)
"Delete a data string from EWOC.
-Can not be used on the footer. Returns the wrapper that is deleted.
+Can not be used on the footer. Returns the wrapper that is deleted.
The start-marker in the wrapper is set to nil, so that it doesn't
consume any more resources."
(let ((dll (ewoc--dll ewoc))
@@ -303,14 +304,14 @@ The ewoc will be inserted in the current buffer at the current position.
PRETTY-PRINTER should be a function that takes one argument, an
element, and inserts a string representing it in the buffer (at
-point). The string PRETTY-PRINTER inserts may be empty or span
-several linse. A trailing newline will always be inserted
-automatically. The PRETTY-PRINTER should use insert, and not
-insert-before-markers.
-
-Optional third argument HEADER is a string that will always be
-present at the top of the ewoc. HEADER should end with a
-newline. Optionaly fourth argument FOOTER is similar, and will
+point). The string PRETTY-PRINTER inserts may be empty or span
+several lines. A trailing newline will always be inserted
+automatically. The PRETTY-PRINTER should use `insert', and not
+`insert-before-markers'.
+
+Optional second argument HEADER is a string that will always be
+present at the top of the ewoc. HEADER should end with a
+newline. Optional third argument FOOTER is similar, and will
be inserted at the bottom of the ewoc."
(let ((new-ewoc
(ewoc--create (current-buffer)
@@ -394,9 +395,9 @@ MAP-FUNCTION is applied to the first element first.
If MAP-FUNCTION returns non-nil the element will be refreshed (its
pretty-printer will be called once again).
-Note that the buffer for EWOC will be current buffer when MAP-FUNCTION
-is called. MAP-FUNCTION must restore the current buffer to BUFFER before
-it returns, if it changes it.
+Note that the buffer for EWOC will be the current buffer when
+MAP-FUNCTION is called. MAP-FUNCTION must restore the current
+buffer before it returns, if it changes it.
If more than two arguments are given, the remaining
arguments will be passed to MAP-FUNCTION."
@@ -411,9 +412,9 @@ arguments will be passed to MAP-FUNCTION."
(defun ewoc-filter (ewoc predicate &rest args)
"Remove all elements in EWOC for which PREDICATE returns nil.
Note that the buffer for EWOC will be current-buffer when PREDICATE
-is called. PREDICATE must restore the current buffer before it returns
+is called. PREDICATE must restore the current buffer before it returns
if it changes it.
-The PREDICATE is called with the element as its first argument. If any
+The PREDICATE is called with the element as its first argument. If any
ARGS are given they will be passed to the PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
((node (ewoc--node-nth dll 1))
@@ -428,7 +429,7 @@ ARGS are given they will be passed to the PREDICATE."
(defun ewoc-locate (ewoc &optional pos guess)
"Return the node that POS (a buffer position) is within.
POS may be a marker or an integer. It defaults to point.
-GUESS should be a node that it is likely that POS is near.
+GUESS should be a node that it is likely to be near POS.
If POS points before the first element, the first node is returned.
If POS points after the last element, the last node is returned.
@@ -497,7 +498,7 @@ If the EWOC is empty, nil is returned."
(defun ewoc-invalidate (ewoc &rest nodes)
"Refresh some elements.
-The pretty-printer that for EWOC will be called for all NODES."
+The pretty-printer set for EWOC will be called for all NODES."
(ewoc--set-buffer-bind-dll ewoc
(dolist (node nodes)
(ewoc--refresh-node (ewoc--pretty-printer ewoc) node))))
@@ -564,13 +565,13 @@ number of elements needs to be refreshed."
(defun ewoc-collect (ewoc predicate &rest args)
"Select elements from EWOC using PREDICATE.
Return a list of all selected data elements.
-PREDICATE is a function that takes a data element as its first argument.
-The elements on the returned list will appear in the same order as in
-the buffer. You should not rely on in which order PREDICATE is
-called.
-Note that the buffer the EWOC is displayed in is current-buffer
-when PREDICATE is called. If PREDICATE must restore current-buffer if
-it changes it.
+PREDICATE is a function that takes a data element as its first
+argument. The elements on the returned list will appear in the
+same order as in the buffer. You should not rely on the order of
+calls to PREDICATE.
+Note that the buffer the EWOC is displayed in is the current
+buffer when PREDICATE is called. PREDICATE must restore it if it
+changes it.
If more than two arguments are given the
remaining arguments will be passed to PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 5a7cd1093c4..54efd14b358 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -1,6 +1,6 @@
;;; find-func.el --- find the definition of the Emacs Lisp function near point
-;; Copyright (C) 1997, 1999, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001, 2004 Free Software Foundation, Inc.
;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp>
;; Maintainer: petersen@kurims.kyoto-u.ac.jp
@@ -128,6 +128,40 @@ See the functions `find-function' and `find-variable'."
(append (find-library-suffixes) '("")))
(error "Can't find library %s" library)))
+(defvar find-function-C-source-directory
+ (let ((dir (expand-file-name "src" source-directory)))
+ (when (and (file-directory-p dir) (file-readable-p dir))
+ dir))
+ "Directory where the C source files of Emacs can be found.
+If nil, do not try to find the source code of functions and variables
+defined in C.")
+
+(defun find-function-C-source (fun-or-var file variable-p)
+ "Find the source location where SUBR-OR-VAR is defined in FILE.
+VARIABLE-P should be non-nil for a variable or nil for a subroutine."
+ (unless find-function-C-source-directory
+ (setq find-function-C-source-directory
+ (read-directory-name "Emacs C source dir: " nil nil t)))
+ (setq file (expand-file-name file find-function-C-source-directory))
+ (unless (file-readable-p file)
+ (error "The C source file %s is not available"
+ (file-name-nondirectory file)))
+ (unless variable-p
+ (setq fun-or-var (indirect-function fun-or-var)))
+ (with-current-buffer (find-file-noselect file)
+ (goto-char (point-min))
+ (unless (re-search-forward
+ (if variable-p
+ (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\""
+ (regexp-quote (symbol-name fun-or-var))
+ "\"")
+ (concat "DEFUN[ \t\n]*([ \t\n]*\""
+ (regexp-quote (subr-name fun-or-var))
+ "\""))
+ nil t)
+ (error "Can't find source for %s" fun-or-var))
+ (cons (current-buffer) (match-beginning 0))))
+
;;;###autoload
(defun find-library (library)
"Find the elisp source of LIBRARY."
@@ -149,9 +183,10 @@ If VARIABLE-P is nil, `find-function-regexp' is used, otherwise
(error "Don't know where `%s' is defined" symbol))
;; Some functions are defined as part of the construct
;; that defines something else.
- (while (get symbol 'definition-name)
+ (while (and (symbolp symbol) (get symbol 'definition-name))
(setq symbol (get symbol 'definition-name)))
- (save-match-data
+ (if (string-match "\\`src/\\(.*\\.c\\)\\'" library)
+ (find-function-C-source symbol (match-string 1 library) variable-p)
(if (string-match "\\.el\\(c\\)\\'" library)
(setq library (substring library 0 (match-beginning 1))))
(let* ((filename (find-library-name library)))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 8cd0fdf0da0..d471ad79538 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -239,6 +239,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(set-keymap-parent emacs-lisp-mode-map lisp-mode-shared-map)
(define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol)
(define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun)
+ (define-key emacs-lisp-mode-map "\e\C-q" 'indent-pp-sexp)
(define-key emacs-lisp-mode-map [menu-bar] (make-sparse-keymap))
(define-key emacs-lisp-mode-map [menu-bar emacs-lisp]
(cons "Emacs-Lisp" map))
@@ -355,6 +356,14 @@ if that value is non-nil."
(setq imenu-case-fold-search t)
(set-syntax-table lisp-mode-syntax-table)
(run-mode-hooks 'lisp-mode-hook))
+(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default)
+
+(defun lisp-find-tag-default ()
+ (let ((default (find-tag-default)))
+ (when (stringp default)
+ (if (string-match ":+" default)
+ (substring default (match-end 0))
+ default))))
;; Used in old LispM code.
(defalias 'common-lisp-mode 'lisp-mode)
@@ -369,6 +378,7 @@ if that value is non-nil."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\C-x" 'eval-defun)
+ (define-key map "\e\C-q" 'indent-pp-sexp)
(define-key map "\e\t" 'lisp-complete-symbol)
(define-key map "\n" 'eval-print-last-sexp)
map)
@@ -448,7 +458,7 @@ alternative printed representations that can be displayed."
"Return a string representing CHAR as a character rather than as an integer.
If CHAR is not a character, return nil."
(and (integerp char)
- (characterp (event-basic-type char))
+ (eventp char)
(let ((c (event-basic-type char)))
(concat
"?"
@@ -460,7 +470,10 @@ If CHAR is not a character, return nil."
(cond
((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c))
((eq c 127) "\\C-?")
- (t (string c)))))))
+ (t
+ (condition-case nil
+ (string c)
+ (error nil))))))))
(defun eval-last-sexp-1 (eval-last-sexp-arg-internal)
"Evaluate sexp before point; print value in minibuffer.
@@ -524,13 +537,12 @@ With argument, print output into current buffer."
(prin1-to-string value)))
(print-length eval-expression-print-length)
(print-level eval-expression-print-level)
- (char-string (prin1-char value))
(beg (point))
end)
(prog1
(prin1 value)
- (if (and (eq standard-output t) char-string)
- (princ (concat " = " char-string)))
+ (let ((str (eval-expression-print-format value)))
+ (if str (princ str)))
(setq end (point))
(when (and (bufferp standard-output)
(or (not (null print-length))
@@ -558,8 +570,9 @@ Interactively, with prefix argument, print output into current buffer."
value)))
(defun eval-defun-1 (form)
- "Change defvar into defconst within FORM.
-Likewise for other constructs as necessary."
+ "Treat some expressions specially.
+Reset the `defvar' and `defcustom' variables to the initial value.
+Reinitialize the face according to the `defface' specification."
;; The code in edebug-defun should be consistent with this, but not
;; the same, since this gets a macroexpended form.
(cond ((not (listp form))
@@ -577,6 +590,13 @@ Likewise for other constructs as necessary."
;; Force variable to be bound.
(set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form))))
form)
+ ;; `defface' is macroexpanded to `custom-declare-face'.
+ ((eq (car form) 'custom-declare-face)
+ ;; Reset the face.
+ (put (eval (nth 1 form)) 'face-defface-spec nil)
+ (setq face-new-frame-defaults
+ (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults))
+ form)
((eq (car form) 'progn)
(cons 'progn (mapcar 'eval-defun-1 (cdr form))))
(t form)))
@@ -612,7 +632,7 @@ Return the result of evaluation."
(setq beg (point))
(setq form (read (current-buffer)))
(setq end (point)))
- ;; Alter the form if necessary, changing defvar into defconst, etc.
+ ;; Alter the form if necessary.
(setq form (eval-defun-1 (macroexpand form)))
(list beg end standard-output
`(lambda (ignore)
@@ -1084,6 +1104,19 @@ ENDPOS is encountered."
(indent-sexp endmark)
(set-marker endmark nil))))
+(defun indent-pp-sexp (&optional arg)
+ "Indent each line of the list or, with prefix ARG, pretty-printify the list."
+ (interactive "P")
+ (if arg
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (progn (forward-sexp 1) (point)))
+ (pp-buffer)
+ (goto-char (point-max))
+ (if (eq (char-before) ?\n)
+ (delete-char -1)))))
+ (indent-sexp))
+
;;;; Lisp paragraph filling commands.
(defcustom emacs-lisp-docstring-fill-column 65
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index e1ed508b865..25fde86cd96 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -175,6 +175,8 @@ open-parenthesis, and point ends up at the beginning of the line.
If variable `beginning-of-defun-function' is non-nil, its value
is called as a function to find the defun's beginning."
(interactive "p")
+ (and (eq this-command 'beginning-of-defun)
+ (or (eq last-command 'beginning-of-defun) (push-mark)))
(and (beginning-of-defun-raw arg)
(progn (beginning-of-line) t)))
@@ -223,6 +225,8 @@ matches the open-parenthesis that starts a defun; see function
If variable `end-of-defun-function' is non-nil, its value
is called as a function to find the defun's end."
(interactive "p")
+ (and (eq this-command 'end-of-defun)
+ (or (eq last-command 'end-of-defun) (push-mark)))
(if (or (null arg) (= arg 0)) (setq arg 1))
(if end-of-defun-function
(if (> arg 0)
@@ -277,15 +281,31 @@ already marked."
(end-of-defun)
(point))))
(t
- ;; Do it in this order for the sake of languages with nested
- ;; functions where several can end at the same place as with
- ;; the offside rule, e.g. Python.
- (push-mark (point))
- (beginning-of-defun)
- (push-mark (point) nil t)
- (end-of-defun)
- (exchange-point-and-mark)
- (re-search-backward "^\n" (- (point) 1) t))))
+ (let ((opoint (point))
+ beg end)
+ (push-mark opoint)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+ (beginning-of-defun)
+ (setq beg (point))
+ (end-of-defun)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (if (> (point) opoint)
+ (progn
+ ;; We got the right defun.
+ (push-mark beg nil t)
+ (goto-char end)
+ (exchange-point-and-mark))
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (push-mark (point) nil t)
+ (beginning-of-defun))
+ (re-search-backward "^\n" (- (point) 1) t)))))
(defun narrow-to-defun (&optional arg)
"Make text outside current defun invisible.
@@ -294,37 +314,112 @@ Optional ARG is ignored."
(interactive)
(save-excursion
(widen)
- ;; Do it in this order for the sake of languages with nested
- ;; functions where several can end at the same place as with the
- ;; offside rule, e.g. Python.
- (beginning-of-defun)
- (let ((beg (point)))
+ (let ((opoint (point))
+ beg end)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+ (beginning-of-defun)
+ (setq beg (point))
(end-of-defun)
- (narrow-to-region beg (point)))))
-
-(defun insert-parentheses (arg)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (unless (> (point) opoint)
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (setq end (point))
+ (beginning-of-defun)
+ (setq beg (point)))
+ (goto-char end)
+ (re-search-backward "^\n" (- (point) 1) t)
+ (narrow-to-region beg end))))
+
+(defvar insert-pair-alist
+ '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\'))
+ "Alist of paired characters inserted by `insert-pair'.
+Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR
+OPEN-CHAR CLOSE-CHAR). The characters OPEN-CHAR and CLOSE-CHAR
+of the pair whose key is equal to the last input character with
+or without modifiers, are inserted by `insert-pair'.")
+
+(defun insert-pair (&optional arg open close)
+ "Enclose following ARG sexps in a pair of OPEN and CLOSE characters.
+Leave point after the first character.
+A negative ARG encloses the preceding ARG sexps instead.
+No argument is equivalent to zero: just insert characters
+and leave point between.
+If `parens-require-spaces' is non-nil, this command also inserts a space
+before and after, depending on the surrounding characters.
+If region is active, insert enclosing characters at region boundaries.
+
+If arguments OPEN and CLOSE are nil, the character pair is found
+from the variable `insert-pair-alist' according to the last input
+character with or without modifiers. If no character pair is
+found in the variable `insert-pair-alist', then the last input
+character is inserted ARG times."
+ (interactive "P")
+ (if (not (and open close))
+ (let ((pair (or (assq last-command-char insert-pair-alist)
+ (assq (event-basic-type last-command-event)
+ insert-pair-alist))))
+ (if pair
+ (if (nth 2 pair)
+ (setq open (nth 1 pair) close (nth 2 pair))
+ (setq open (nth 0 pair) close (nth 1 pair))))))
+ (if (and open close)
+ (if (and transient-mark-mode mark-active)
+ (progn
+ (save-excursion (goto-char (region-end)) (insert close))
+ (save-excursion (goto-char (region-beginning)) (insert open)))
+ (if arg (setq arg (prefix-numeric-value arg))
+ (setq arg 0))
+ (cond ((> arg 0) (skip-chars-forward " \t"))
+ ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
+ (and parens-require-spaces
+ (not (bobp))
+ (memq (char-syntax (preceding-char)) (list ?w ?_ (char-syntax close)))
+ (insert " "))
+ (insert open)
+ (save-excursion
+ (or (eq arg 0) (forward-sexp arg))
+ (insert close)
+ (and parens-require-spaces
+ (not (eobp))
+ (memq (char-syntax (following-char)) (list ?w ?_ (char-syntax open)))
+ (insert " "))))
+ (insert-char (event-basic-type last-command-event)
+ (prefix-numeric-value arg))))
+
+(defun insert-parentheses (&optional arg)
"Enclose following ARG sexps in parentheses. Leave point after open-paren.
A negative ARG encloses the preceding ARG sexps instead.
No argument is equivalent to zero: just insert `()' and leave point between.
If `parens-require-spaces' is non-nil, this command also inserts a space
-before and after, depending on the surrounding characters."
+before and after, depending on the surrounding characters.
+If region is active, insert enclosing characters at region boundaries."
(interactive "P")
- (if arg (setq arg (prefix-numeric-value arg))
- (setq arg 0))
- (cond ((> arg 0) (skip-chars-forward " \t"))
- ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
- (and parens-require-spaces
- (not (bobp))
- (memq (char-syntax (preceding-char)) '(?w ?_ ?\) ))
- (insert " "))
- (insert ?\()
- (save-excursion
- (or (eq arg 0) (forward-sexp arg))
- (insert ?\))
- (and parens-require-spaces
- (not (eobp))
- (memq (char-syntax (following-char)) '(?w ?_ ?\( ))
- (insert " "))))
+ (insert-pair arg ?\( ?\)))
+
+(defun delete-pair ()
+ "Delete a pair of characters enclosing the sexp that follows point."
+ (interactive)
+ (save-excursion (forward-sexp 1) (delete-char -1))
+ (delete-char 1))
+
+(defun raise-sexp (&optional arg)
+ "Raise ARG sexps higher up the tree."
+ (interactive "p")
+ (let ((s (if (and transient-mark-mode mark-active)
+ (buffer-substring (region-beginning) (region-end))
+ (buffer-substring
+ (point)
+ (save-excursion (forward-sexp arg) (point))))))
+ (backward-up-list 1)
+ (delete-region (point) (save-excursion (forward-sexp 1) (point)))
+ (save-excursion (insert s))))
(defun move-past-close-and-reindent ()
"Move past next `)', delete indentation before it, then indent after it."
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index c93868859f0..61d31921e57 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -50,34 +50,40 @@ to make output that `read' can handle, whenever this is possible."
(let ((print-escape-newlines pp-escape-newlines)
(print-quoted t))
(prin1 object (current-buffer)))
- (goto-char (point-min))
- (while (not (eobp))
- ;; (message "%06d" (- (point-max) (point)))
- (cond
- ((condition-case err-var
- (prog1 t (down-list 1))
- (error nil))
- (save-excursion
- (backward-char 1)
- (skip-chars-backward "'`#^")
- (when (and (not (bobp)) (= ?\ (char-before)))
- (delete-char -1)
- (insert "\n"))))
- ((condition-case err-var
- (prog1 t (up-list 1))
- (error nil))
- (while (looking-at "\\s)")
- (forward-char 1))
- (delete-region
- (point)
- (progn (skip-chars-forward " \t") (point)))
- (insert ?\n))
- (t (goto-char (point-max)))))
- (goto-char (point-min))
- (indent-sexp)
+ (pp-buffer)
(buffer-string))
(kill-buffer (current-buffer)))))
+(defun pp-buffer ()
+ "Prettify the current buffer with printed representation of a Lisp object."
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; (message "%06d" (- (point-max) (point)))
+ (cond
+ ((condition-case err-var
+ (prog1 t (down-list 1))
+ (error nil))
+ (save-excursion
+ (backward-char 1)
+ (skip-chars-backward "'`#^")
+ (when (and (not (bobp)) (memq (char-before) '(?\ ?\t ?\n)))
+ (delete-region
+ (point)
+ (progn (skip-chars-backward " \t\n") (point)))
+ (insert "\n"))))
+ ((condition-case err-var
+ (prog1 t (up-list 1))
+ (error nil))
+ (while (looking-at "\\s)")
+ (forward-char 1))
+ (delete-region
+ (point)
+ (progn (skip-chars-forward " \t\n") (point)))
+ (insert ?\n))
+ (t (goto-char (point-max)))))
+ (goto-char (point-min))
+ (indent-sexp))
+
;;;###autoload
(defun pp (object &optional stream)
"Output the pretty-printed representation of OBJECT, any Lisp object.
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index 9c904e6c0bc..83d3649006e 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -494,7 +494,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(defun reb-auto-update (beg end lenold &optional force)
"Called from `after-update-functions' to update the display.
-BEG END and LENOLD are passed in from the hook.
+BEG, END and LENOLD are passed in from the hook.
An actual update is only done if the regexp has changed or if the
optional fourth argument FORCE is non-nil."
(let ((prev-valid reb-valid-string)
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 6656cf5ed3c..d4a10104eea 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1,6 +1,6 @@
;;; rx.el --- sexp notation for regular expressions
-;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 03, 2004 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: FSF
@@ -32,6 +32,22 @@
;; from the bugs mentioned in the commentary section of Sregex, and
;; uses a nicer syntax (IMHO, of course :-).
+;; This significantly extended version of the original, is almost
+;; compatible with Sregex. The only incompatibility I (fx) know of is
+;; that the `repeat' form can't have multiple regexp args.
+
+;; Now alternative forms are provided for a degree of compatibility
+;; with Shivers' attempted definitive SRE notation
+;; <URL:http://www.ai.mit.edu/~/shivers/sre.txt>. SRE forms not
+;; catered for include: dsm, uncase, w/case, w/nocase, ,@<exp>,
+;; ,<exp>, (word ...), word+, posix-string, and character class forms.
+;; Some forms are inconsistent with SRE, either for historical reasons
+;; or because of the implementation -- simple translation into Emacs
+;; regexp strings. These include: any, word. Also, case-sensitivity
+;; and greediness are controlled by variables external to the regexp,
+;; and you need to feed the forms to the `posix-' functions to get
+;; SRE's POSIX semantics. There are probably more difficulties.
+
;; Rx translates a sexp notation for regular expressions into the
;; usual string notation. The translation can be done at compile-time
;; by using the `rx' macro. It can be done at run-time by calling
@@ -94,62 +110,103 @@
;;; Code:
-
(defconst rx-constituents
'((and . (rx-and 1 nil))
+ (seq . and) ; SRE
+ (: . and) ; SRE
+ (sequence . and) ; sregex
(or . (rx-or 1 nil))
+ (| . or) ; SRE
(not-newline . ".")
+ (nonl . not-newline) ; SRE
(anything . ".\\|\n")
- (any . (rx-any 1 1 rx-check-any))
+ (any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE
(in . any)
+ (char . any) ; sregex
+ (not-char . (rx-not-char 1 nil rx-check-any)) ; sregex
(not . (rx-not 1 1 rx-check-not))
+ ;; Partially consistent with sregex, whose `repeat' is like our
+ ;; `**'. (`repeat' with optional max arg and multiple sexp forms
+ ;; is ambiguous.)
(repeat . (rx-repeat 2 3))
- (submatch . (rx-submatch 1 nil))
+ (= . (rx-= 2 nil)) ; SRE
+ (>= . (rx->= 2 nil)) ; SRE
+ (** . (rx-** 2 nil)) ; SRE
+ (submatch . (rx-submatch 1 nil)) ; SRE
(group . submatch)
- (zero-or-more . (rx-kleene 1 1))
- (one-or-more . (rx-kleene 1 1))
- (zero-or-one . (rx-kleene 1 1))
- (\? . zero-or-one)
+ (zero-or-more . (rx-kleene 1 nil))
+ (one-or-more . (rx-kleene 1 nil))
+ (zero-or-one . (rx-kleene 1 nil))
+ (\? . zero-or-one) ; SRE
(\?? . zero-or-one)
- (* . zero-or-more)
+ (* . zero-or-more) ; SRE
(*? . zero-or-more)
(0+ . zero-or-more)
- (+ . one-or-more)
+ (+ . one-or-more) ; SRE
(+? . one-or-more)
(1+ . one-or-more)
(optional . zero-or-one)
+ (opt . zero-or-one) ; sregex
(minimal-match . (rx-greedy 1 1))
(maximal-match . (rx-greedy 1 1))
(backref . (rx-backref 1 1 rx-check-backref))
(line-start . "^")
+ (bol . line-start) ; SRE
(line-end . "$")
+ (eol . line-end) ; SRE
(string-start . "\\`")
+ (bos . string-start) ; SRE
+ (bot . string-start) ; sregex
(string-end . "\\'")
+ (eos . string-end) ; SRE
+ (eot . string-end) ; sregex
(buffer-start . "\\`")
(buffer-end . "\\'")
(point . "\\=")
(word-start . "\\<")
+ (bow . word-start) ; SRE
(word-end . "\\>")
+ (eow . word-end) ; SRE
(word-boundary . "\\b")
+ (not-word-boundary . "\\B") ; sregex
(syntax . (rx-syntax 1 1))
+ (not-syntax . (rx-not-syntax 1 1)) ; sregex
(category . (rx-category 1 1 rx-check-category))
(eval . (rx-eval 1 1))
(regexp . (rx-regexp 1 1 stringp))
(digit . "[[:digit:]]")
- (control . "[[:cntrl:]]")
- (hex-digit . "[[:xdigit:]]")
- (blank . "[[:blank:]]")
- (graphic . "[[:graph:]]")
- (printing . "[[:print:]]")
- (alphanumeric . "[[:alnum:]]")
+ (numeric . digit) ; SRE
+ (num . digit) ; SRE
+ (control . "[[:cntrl:]]") ; SRE
+ (cntrl . control) ; SRE
+ (hex-digit . "[[:xdigit:]]") ; SRE
+ (hex . hex-digit) ; SRE
+ (xdigit . hex-digit) ; SRE
+ (blank . "[[:blank:]]") ; SRE
+ (graphic . "[[:graph:]]") ; SRE
+ (graph . graphic) ; SRE
+ (printing . "[[:print:]]") ; SRE
+ (print . printing) ; SRE
+ (alphanumeric . "[[:alnum:]]") ; SRE
+ (alnum . alphanumeric) ; SRE
(letter . "[[:alpha:]]")
- (ascii . "[[:ascii:]]")
+ (alphabetic . letter) ; SRE
+ (alpha . letter) ; SRE
+ (ascii . "[[:ascii:]]") ; SRE
(nonascii . "[[:nonascii:]]")
- (lower . "[[:lower:]]")
- (punctuation . "[[:punct:]]")
- (space . "[[:space:]]")
- (upper . "[[:upper:]]")
- (word . "[[:word:]]"))
+ (lower . "[[:lower:]]") ; SRE
+ (lower-case . lower) ; SRE
+ (punctuation . "[[:punct:]]") ; SRE
+ (punct . punctuation) ; SRE
+ (space . "[[:space:]]") ; SRE
+ (whitespace . space) ; SRE
+ (white . space) ; SRE
+ (upper . "[[:upper:]]") ; SRE
+ (upper-case . upper) ; SRE
+ (word . "[[:word:]]") ; inconsistent with SRE
+ (wordchar . word) ; sregex
+ (not-wordchar . "[^[:word:]]") ; sregex (use \\W?)
+ )
"Alist of sexp form regexp constituents.
Each element of the alist has the form (SYMBOL . DEFN).
SYMBOL is a valid constituent of sexp regular expressions.
@@ -252,6 +309,8 @@ See also `rx-constituents'."
(defun rx-check (form)
"Check FORM according to its car's parsing info."
+ (unless (listp form)
+ (error "rx `%s' needs argument(s)" form))
(let* ((rx (rx-info (car form)))
(nargs (1- (length form)))
(min-args (nth 1 rx))
@@ -297,53 +356,61 @@ FORM is of the form `(and FORM1 ...)'."
"\\)")))
-(defun rx-quote-for-set (string)
- "Transform STRING for use in a character set.
-If STRING contains a `]', move it to the front.
-If STRING starts with a '^', move it to the end."
- (when (string-match "\\`\\(\\(?:.\\|\n\\)+\\)\\]\\(\\(?:.\\|\n\\)\\)*\\'"
- string)
- (setq string (concat "]" (match-string 1 string)
- (match-string 2 string))))
- (when (string-match "\\`^\\(\\(?:.\\|\n\\)+\\)\\'" string)
- (setq string (concat (substring string 1) "^")))
- string)
-
+(defvar rx-bracket) ; dynamically bound in `rx-any'
(defun rx-check-any (arg)
"Check arg ARG for Rx `any'."
- (cond ((integerp arg) t)
- ((and (stringp arg) (zerop (length arg)))
- (error "String arg for rx `any' must not be empty"))
- ((stringp arg) t)
- (t
- (error "rx `any' requires string or character arg"))))
-
+ (if (integerp arg)
+ (setq arg (string arg)))
+ (when (stringp arg)
+ (if (zerop (length arg))
+ (error "String arg for Rx `any' must not be empty"))
+ ;; Quote ^ at start; don't bother to check whether this is first arg.
+ (if (eq ?^ (aref arg 0))
+ (setq arg (concat "\\" arg)))
+ ;; Remove ] and set flag for adding it to start of overall result.
+ (when (string-match "]" arg)
+ (setq arg (replace-regexp-in-string "]" "" arg)
+ rx-bracket "]")))
+ (when (symbolp arg)
+ (let ((translation (condition-case nil
+ (rx-to-string arg 'no-group)
+ (error nil))))
+ (unless translation (error "Invalid char class `%s' in Rx `any'" arg))
+ (setq arg (substring translation 1 -1)))) ; strip outer brackets
+ ;; sregex compatibility
+ (when (and (integerp (car-safe arg))
+ (integerp (cdr-safe arg)))
+ (setq arg (string (car arg) ?- (cdr arg))))
+ (unless (stringp arg)
+ (error "rx `any' requires string, character, char pair or char class args"))
+ arg)
(defun rx-any (form)
- "Parse and produce code from FORM, which is `(any STRING)'.
-STRING is optional. If it is omitted, build a regexp that
-matches anything."
+ "Parse and produce code from FORM, which is `(any ARG ...)'.
+ARG is optional."
(rx-check form)
- (let ((arg (cadr form)))
- (cond ((integerp arg)
- (char-to-string arg))
- ((= (length arg) 1)
- arg)
- (t
- (concat "[" (rx-quote-for-set (cadr form)) "]")))))
+ (let* ((rx-bracket nil)
+ (args (mapcar #'rx-check-any (cdr form)))) ; side-effects `rx-bracket'
+ ;; If there was a ?- in the form, move it to the front to avoid
+ ;; accidental range.
+ (if (member "-" args)
+ (setq args (cons "-" (delete "-" args))))
+ (apply #'concat "[" rx-bracket (append args '("]")))))
(defun rx-check-not (arg)
"Check arg ARG for Rx `not'."
- (unless (or (memq form
- '(digit control hex-digit blank graphic printing
- alphanumeric letter ascii nonascii lower
- punctuation space upper word))
- (and (consp form)
- (memq (car form) '(not any in syntax category:))))
- (error "rx `not' syntax error: %s" form))
- t)
+ (unless (or (and (symbolp arg)
+ (string-match "\\`\\[\\[:[-a-z]:]]\\'"
+ (condition-case nil
+ (rx-to-string arg 'no-group)
+ (error ""))))
+ (eq arg 'word-boundary)
+ (and (consp arg)
+ (memq (car arg) '(not any in syntax category))))
+ (error "rx `not' syntax error: %s" arg))
+ t)
(defun rx-not (form)
@@ -355,24 +422,67 @@ matches anything."
(if (= (length result) 4)
(substring result 2 3)
(concat "[" (substring result 2))))
- ((string-match "\\`\\[" result)
+ ((eq ?\[ (aref result 0))
(concat "[^" (substring result 1)))
- ((string-match "\\`\\\\s." result)
- (concat "\\S" (substring result 2)))
- ((string-match "\\`\\\\S." result)
- (concat "\\s" (substring result 2)))
- ((string-match "\\`\\\\c." result)
- (concat "\\C" (substring result 2)))
- ((string-match "\\`\\\\C." result)
- (concat "\\c" (substring result 2)))
- ((string-match "\\`\\\\B" result)
- (concat "\\b" (substring result 2)))
- ((string-match "\\`\\\\b" result)
- (concat "\\B" (substring result 2)))
+ ((string-match "\\`\\\\[scb]" result)
+ (concat (capitalize (substring result 0 2)) (substring result 2)))
(t
(concat "[^" result "]")))))
+(defun rx-not-char (form)
+ "Parse and produce code from FORM. FORM is `(not-char ...)'."
+ (rx-check form)
+ (rx-not `(not (in ,@(cdr form)))))
+
+
+(defun rx-not-syntax (form)
+ "Parse and produce code from FORM. FORM is `(not-syntax SYNTAX)'."
+ (rx-check form)
+ (rx-not `(not (syntax ,@(cdr form)))))
+
+
+(defun rx-trans-forms (form &optional skip)
+ "If FORM's length is greater than two, transform it to length two.
+A form (HEAD REST ...) becomes (HEAD (and REST ...)).
+If SKIP is non-nil, allow that number of items after the head, i.e.
+`(= N REST ...)' becomes `(= N (and REST ...))' if SKIP is 1."
+ (unless skip (setq skip 0))
+ (let ((tail (nthcdr (1+ skip) form)))
+ (if (= (length tail) 1)
+ form
+ (let ((form (copy-sequence form)))
+ (setcdr (nthcdr skip form) (list (cons 'and tail)))
+ form))))
+
+
+(defun rx-= (form)
+ "Parse and produce code from FORM `(= N ...)'."
+ (rx-check form)
+ (setq form (rx-trans-forms form 1))
+ (unless (and (integerp (nth 1 form))
+ (> (nth 1 form) 0))
+ (error "rx `=' requires positive integer first arg"))
+ (format "%s\\{%d\\}" (rx-to-string (nth 2 form)) (nth 1 form)))
+
+
+(defun rx->= (form)
+ "Parse and produce code from FORM `(>= N ...)'."
+ (rx-check form)
+ (setq form (rx-trans-forms form 1))
+ (unless (and (integerp (nth 1 form))
+ (> (nth 1 form) 0))
+ (error "rx `>=' requires positive integer first arg"))
+ (format "%s\\{%d,\\}" (rx-to-string (nth 2 form)) (nth 1 form)))
+
+
+(defun rx-** (form)
+ "Parse and produce code from FORM `(** N M ...)'."
+ (rx-check form)
+ (setq form (cons 'repeat (cdr (rx-trans-forms form 2))))
+ (rx-to-string form))
+
+
(defun rx-repeat (form)
"Parse and produce code from FORM.
FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'."
@@ -419,6 +529,7 @@ If OP is one of `*?', `+?', `??', produce a non-greedy regexp.
If OP is anything else, produce a greedy regexp if `rx-greedy-flag'
is non-nil."
(rx-check form)
+ (setq form (rx-trans-forms form))
(let ((suffix (cond ((memq (car form) '(* + ? )) "")
((memq (car form) '(*? +? ??)) "?")
(rx-greedy-flag "")
@@ -468,9 +579,15 @@ of all atomic regexps."
(defun rx-syntax (form)
"Parse and produce code from FORM, which is `(syntax SYMBOL)'."
(rx-check form)
- (let ((syntax (assq (cadr form) rx-syntax)))
+ (let* ((sym (cadr form))
+ (syntax (assq sym rx-syntax)))
(unless syntax
- (error "Unknown rx syntax `%s'" (cadr form)))
+ ;; Try sregex compatibility.
+ (let ((name (symbol-name sym)))
+ (if (= 1 (length name))
+ (setq syntax (rassq (aref name 0) rx-syntax))))
+ (unless syntax
+ (error "Unknown rx syntax `%s'" (cadr form))))
(format "\\s%c" (cdr syntax))))
@@ -483,7 +600,7 @@ of all atomic regexps."
(defun rx-category (form)
- "Parse and produce code from FORM, which is `(category SYMBOL ...)'."
+ "Parse and produce code from FORM, which is `(category SYMBOL)'."
(rx-check form)
(let ((char (if (integerp (cadr form))
(cadr form)
@@ -543,8 +660,9 @@ NO-GROUP non-nil means don't put shy groups around the result."
;;;###autoload
-(defmacro rx (regexp)
- "Translate a regular expression REGEXP in sexp form to a regexp string.
+(defmacro rx (&rest regexps)
+ "Translate regular expressions REGEXPS in sexp form to a regexp string.
+REGEXPS is a non-empty sequence of forms of the sort listed below.
See also `rx-to-string' for how to do such a translation at run-time.
The following are valid subforms of regular expressions in sexp
@@ -556,53 +674,58 @@ STRING
CHAR
matches character CHAR literally.
-`not-newline'
+`not-newline', `nonl'
matches any character except a newline.
.
`anything'
matches any character
-`(any SET)'
- matches any character in SET. SET may be a character or string.
+`(any SET ...)'
+`(in SET ...)'
+`(char SET ...)'
+ matches any character in SET .... SET may be a character or string.
Ranges of characters can be specified as `A-Z' in strings.
+ Ranges may also be specified as conses like `(?A . ?Z)'.
-'(in SET)'
- like `any'.
+ SET may also be the name of a character class: `digit',
+ `control', `hex-digit', `blank', `graph', `print', `alnum',
+ `alpha', `ascii', `nonascii', `lower', `punct', `space', `upper',
+ `word', or one of their synonyms.
-`(not (any SET))'
- matches any character not in SET
+`(not (any SET ...))'
+ matches any character not in SET ...
-`line-start'
+`line-start', `bol'
matches the empty string, but only at the beginning of a line
in the text being matched
-`line-end'
+`line-end', `eol'
is similar to `line-start' but matches only at the end of a line
-`string-start'
+`string-start', `bos', `bot'
matches the empty string, but only at the beginning of the
string being matched against.
-`string-end'
+`string-end', `eos', `eot'
matches the empty string, but only at the end of the
string being matched against.
`buffer-start'
matches the empty string, but only at the beginning of the
- buffer being matched against.
+ buffer being matched against. Actually equivalent to `string-start'.
`buffer-end'
matches the empty string, but only at the end of the
- buffer being matched against.
+ buffer being matched against. Actually equivalent to `string-end'.
`point'
matches the empty string, but only at point.
-`word-start'
+`word-start', `bow'
matches the empty string, but only at the beginning or end of a
word.
-`word-end'
+`word-end', `eow'
matches the empty string, but only at the end of a word.
`word-boundary'
@@ -610,34 +733,35 @@ CHAR
word.
`(not word-boundary)'
+`not-word-boundary'
matches the empty string, but not at the beginning or end of a
word.
-`digit'
+`digit', `numeric', `num'
matches 0 through 9.
-`control'
+`control', `cntrl'
matches ASCII control characters.
-`hex-digit'
+`hex-digit', `hex', `xdigit'
matches 0 through 9, a through f and A through F.
`blank'
matches space and tab only.
-`graphic'
+`graphic', `graph'
matches graphic characters--everything except ASCII control chars,
space, and DEL.
-`printing'
+`printing', `print'
matches printing characters--everything except ASCII control chars
and DEL.
-`alphanumeric'
+`alphanumeric', `alnum'
matches letters and digits. (But at present, for multibyte characters,
it matches anything that has word syntax.)
-`letter'
+`letter', `alphabetic', `alpha'
matches letters. (But at present, for multibyte characters,
it matches anything that has word syntax.)
@@ -647,25 +771,29 @@ CHAR
`nonascii'
matches non-ASCII (multibyte) characters.
-`lower'
+`lower', `lower-case'
matches anything lower-case.
-`upper'
+`upper', `upper-case'
matches anything upper-case.
-`punctuation'
+`punctuation', `punct'
matches punctuation. (But at present, for multibyte characters,
it matches anything that has non-word syntax.)
-`space'
+`space', `whitespace', `white'
matches anything that has whitespace syntax.
-`word'
+`word', `wordchar'
matches anything that has word syntax.
+`not-wordchar'
+ matches anything that has non-word syntax.
+
`(syntax SYNTAX)'
matches a character with syntax SYNTAX. SYNTAX must be one
- of the following symbols.
+ of the following symbols, or a symbol corresponding to the syntax
+ character, e.g. `\\.' for `\\s.'.
`whitespace' (\\s- in string notation)
`punctuation' (\\s.)
@@ -684,7 +812,7 @@ CHAR
`comment-delimiter' (\\s!)
`(not (syntax SYNTAX))'
- matches a character that has not syntax SYNTAX.
+ matches a character that doesn't have syntax SYNTAX.
`(category CATEGORY)'
matches a character with category CATEGORY. CATEGORY must be
@@ -710,7 +838,7 @@ CHAR
`japanese-katakana-two-byte' (\\cK)
`korean-hangul-two-byte' (\\cN)
`cyrillic-two-byte' (\\cY)
- `combining-diacritic' (\\c^)
+ `combining-diacritic' (\\c^)
`ascii' (\\ca)
`arabic' (\\cb)
`chinese' (\\cc)
@@ -731,12 +859,16 @@ CHAR
`can-break' (\\c|)
`(not (category CATEGORY))'
- matches a character that has not category CATEGORY.
+ matches a character that doesn't have category CATEGORY.
`(and SEXP1 SEXP2 ...)'
+`(: SEXP1 SEXP2 ...)'
+`(seq SEXP1 SEXP2 ...)'
+`(sequence SEXP1 SEXP2 ...)'
matches what SEXP1 matches, followed by what SEXP2 matches, etc.
`(submatch SEXP1 SEXP2 ...)'
+`(group SEXP1 SEXP2 ...)'
like `and', but makes the match accessible with `match-end',
`match-beginning', and `match-string'.
@@ -744,6 +876,7 @@ CHAR
another name for `submatch'.
`(or SEXP1 SEXP2 ...)'
+`(| SEXP1 SEXP2 ...)'
matches anything that matches SEXP1 or SEXP2, etc. If all
args are strings, use `regexp-opt' to optimize the resulting
regular expression.
@@ -757,47 +890,55 @@ CHAR
`(maximal-match SEXP)'
produce a greedy regexp for SEXP. This is the default.
-`(zero-or-more SEXP)'
- matches zero or more occurrences of what SEXP matches.
-
-`(0+ SEXP)'
- like `zero-or-more'.
+Below, `SEXP ...' represents a sequence of regexp forms, treated as if
+enclosed in `(and ...)'.
-`(* SEXP)'
- like `zero-or-more', but always produces a greedy regexp.
+`(zero-or-more SEXP ...)'
+`(0+ SEXP ...)'
+ matches zero or more occurrences of what SEXP ... matches.
-`(*? SEXP)'
- like `zero-or-more', but always produces a non-greedy regexp.
+`(* SEXP ...)'
+ like `zero-or-more', but always produces a greedy regexp, independent
+ of `rx-greedy-flag'.
-`(one-or-more SEXP)'
- matches one or more occurrences of A.
+`(*? SEXP ...)'
+ like `zero-or-more', but always produces a non-greedy regexp,
+ independent of `rx-greedy-flag'.
-`(1+ SEXP)'
- like `one-or-more'.
+`(one-or-more SEXP ...)'
+`(1+ SEXP ...)'
+ matches one or more occurrences of SEXP ...
-`(+ SEXP)'
+`(+ SEXP ...)'
like `one-or-more', but always produces a greedy regexp.
-`(+? SEXP)'
+`(+? SEXP ...)'
like `one-or-more', but always produces a non-greedy regexp.
-`(zero-or-one SEXP)'
+`(zero-or-one SEXP ...)'
+`(optional SEXP ...)'
+`(opt SEXP ...)'
matches zero or one occurrences of A.
-`(optional SEXP)'
- like `zero-or-one'.
-
-`(? SEXP)'
+`(? SEXP ...)'
like `zero-or-one', but always produces a greedy regexp.
-`(?? SEXP)'
+`(?? SEXP ...)'
like `zero-or-one', but always produces a non-greedy regexp.
`(repeat N SEXP)'
- matches N occurrences of what SEXP matches.
+`(= N SEXP ...)'
+ matches N occurrences.
+
+`(>= N SEXP ...)'
+ matches N or more occurrences.
`(repeat N M SEXP)'
- matches N to M occurrences of what SEXP matches.
+`(** N M SEXP ...)'
+ matches N to M occurrences.
+
+`(backref N)'
+ matches what was matched previously by submatch N.
`(backref N)'
matches what was matched previously by submatch N.
@@ -811,9 +952,21 @@ CHAR
`(regexp REGEXP)'
include REGEXP in string notation in the result."
-
- (rx-to-string regexp))
-
+ (cond ((null regexps)
+ (error "No regexp"))
+ ((cdr regexps)
+ (rx-to-string `(and ,@regexps) t))
+ (t
+ (rx-to-string (car regexps) t))))
+
+;; ;; sregex.el replacement
+
+;; ;;;###autoload (provide 'sregex)
+;; ;;;###autoload (autoload 'sregex "rx")
+;; (defalias 'sregex 'rx-to-string)
+;; ;;;###autoload (autoload 'sregexq "rx" nil nil 'macro)
+;; (defalias 'sregexq 'rx)
+
(provide 'rx)
;;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 4ab2ac8e0d4..336a1ff82d0 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -161,7 +161,7 @@ fire repeatedly that many seconds apart."
(aset timer 6 args)
timer)
-(defun timer-activate (timer)
+(defun timer-activate (timer &optional triggered-p)
"Put TIMER on the list of active timers."
(if (and (timerp timer)
(integerp (aref timer 1))
@@ -184,7 +184,7 @@ fire repeatedly that many seconds apart."
(if last
(setcdr last (cons timer timers))
(setq timer-list (cons timer timers)))
- (aset timer 0 nil)
+ (aset timer 0 triggered-p)
(aset timer 7 nil)
nil)
(error "Invalid or uninitialized timer")))
@@ -270,7 +270,7 @@ This function is called, by name, directly by the C code."
(setq timer-event-last timer)
(let ((inhibit-quit t))
(if (timerp timer)
- (progn
+ (let (retrigger)
;; Delete from queue.
(cancel-timer timer)
;; Re-schedule if requested.
@@ -287,13 +287,16 @@ This function is called, by name, directly by the C code."
(aref timer 4))))
(if (> repeats timer-max-repeats)
(timer-inc-time timer (* (aref timer 4) repeats)))))
- (timer-activate timer)))
+ (timer-activate timer t)
+ (setq retrigger t)))
;; Run handler.
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
(apply (aref timer 5) (aref timer 6))
- (error nil)))
+ (error nil))
+ (if retrigger
+ (aset timer 0 nil)))
(error "Bogus timer event"))))
;; This function is incompatible with the one in levents.el.
View Lorry Controller Status