diff options
author | Kenichi Handa <handa@m17n.org> | 2004-04-16 12:51:06 +0000 |
---|---|---|
committer | Kenichi Handa <handa@m17n.org> | 2004-04-16 12:51:06 +0000 |
commit | 6b61353c0a0320ee15bb6488149735381fed62ec (patch) | |
tree | e69adba60e504a5a37beb556ad70084de88a7aab /lisp/emacs-lisp | |
parent | dc6a28319312fe81f7a1015e363174022313f0bd (diff) | |
download | emacs-6b61353c0a0320ee15bb6488149735381fed62ec.tar.gz emacs-6b61353c0a0320ee15bb6488149735381fed62ec.tar.bz2 emacs-6b61353c0a0320ee15bb6488149735381fed62ec.zip |
Sync to HEAD
Diffstat (limited to 'lisp/emacs-lisp')
62 files changed, 1832 insertions, 519 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index bc047802720..7686722c5be 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1,6 +1,6 @@ ;;; advice.el --- an overloading mechanism for Emacs Lisp functions -;; Copyright (C) 1993,1994,2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1993,1994,2000,01,2004 Free Software Foundation, Inc. ;; Author: Hans Chalupsky <hans@cs.buffalo.edu> ;; Maintainer: FSF @@ -2563,29 +2563,31 @@ supplied to make subr arglist lookup more efficient." Either use the one stored under the `ad-subr-arglist' property, or try to retrieve it from the docstring and cache it under that property, or otherwise use `(&rest ad-subr-args)'." - (cond ((ad-subr-args-defined-p subr-name) - (ad-get-subr-args subr-name)) - ;; says jwz: Should use this for Lemacs 19.8 and above: - ;;((fboundp 'subr-min-args) - ;; ...) - ;; says hans: I guess what Jamie means is that I should use the values - ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist - ;; without having to look it up via parsing the docstring, e.g., - ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an - ;; argument list. However, that won't work because there is no - ;; way to distinguish a subr with args `(a &optional b &rest c)' from - ;; one with args `(a &rest c)' using that mechanism. Also, the argument - ;; names from the docstring are more meaningful. Hence, I'll stick with - ;; the old way of doing things. - (t (let ((doc (or (ad-real-documentation subr-name t) ""))) - (cond ((string-match "^\\(([^\)]+)\\)\n?\\'" doc) - (ad-define-subr-args - subr-name - (cdr (car (read-from-string - (downcase (match-string 1 doc)))))) - (ad-get-subr-args subr-name)) - ;; This is actually an error. - (t '(&rest ad-subr-args))))))) + (if (ad-subr-args-defined-p subr-name) + (ad-get-subr-args subr-name) + ;; says jwz: Should use this for Lemacs 19.8 and above: + ;;((fboundp 'subr-min-args) + ;; ...) + ;; says hans: I guess what Jamie means is that I should use the values + ;; of `subr-min-args' and `subr-max-args' to construct the subr arglist + ;; without having to look it up via parsing the docstring, e.g., + ;; values 1 and 2 would suggest `(arg1 &optional arg2)' as an + ;; argument list. However, that won't work because there is no + ;; way to distinguish a subr with args `(a &optional b &rest c)' from + ;; one with args `(a &rest c)' using that mechanism. Also, the argument + ;; names from the docstring are more meaningful. Hence, I'll stick with + ;; the old way of doing things. + (let ((doc (or (ad-real-documentation subr-name t) ""))) + (if (not (string-match "\n\n\\((.+)\\)\\'" doc)) + ;; Signalling an error leads to bugs during bootstrapping because + ;; the DOC file is not yet built (which is an error, BTW). + ;; (error "The usage info is missing from the subr %s" subr-name) + '(&rest ad-subr-args) + (ad-define-subr-args + subr-name + (cdr (car (read-from-string + (downcase (match-string 1 doc)))))) + (ad-get-subr-args subr-name))))) (defun ad-docstring (definition) "Return the unexpanded docstring of DEFINITION." @@ -3983,4 +3985,5 @@ Use only in REAL emergencies." (provide 'advice) +;;; arch-tag: 29f8c9a1-8c88-471f-95d7-e28541c6b7c0 ;;; advice.el ends here diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el index 997badc1732..42ce33ad7b7 100644 --- a/lisp/emacs-lisp/assoc.el +++ b/lisp/emacs-lisp/assoc.el @@ -137,4 +137,5 @@ extra values are ignored. Returns the created alist." (provide 'assoc) +;;; arch-tag: 3e58bd89-d912-4b74-a0dc-6ed9735922bc ;;; assoc.el ends here diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 325d3903e89..3d0936a8c46 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -60,7 +60,7 @@ files.") ("Eric S. Raymond" "Eric Raymond") ("Eric Youngdale" "(Eric Youngdale at youngdale@v6550c.nrl.navy.mil)") ("Fran,Ag(Bois Pinard" "Francois Pinard") - ("Francesco Potorti" "Francesco Potorti`") + ("Francesco Potort,Al(B" "Francesco Potorti" "Francesco Potorti`") ("Frederic Pierresteguy" "Fred Pierresteguy") ("Geoff Voelker" "voelker") ("Hallvard B. Furuseth" "Hallvard B Furuseth") @@ -638,4 +638,5 @@ the Emacs source tree, from which to build the file." (authors root) (write-file file))) +;;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1 ;;; authors.el ends here diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 7aafeb3bebc..43da3d09827 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -567,4 +567,5 @@ Calls `update-directory-autoloads' on the command line arguments." (provide 'autoload) +;;; arch-tag: 00244766-98f4-4767-bf42-8a22103441c6 ;;; autoload.el ends here diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index eafa63d6e32..6a2baeb3fe9 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -1,6 +1,6 @@ ;;; backquote.el --- implement the ` Lisp construct -;;; Copyright (C) 1990, 1992, 1994, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1990, 92, 1994, 2001, 2004 Free Software Foundation, Inc. ;; Author: Rick Sladkey <jrs@world.std.com> ;; Maintainer: FSF @@ -44,6 +44,9 @@ "Like `list' but the last argument is the tail of the new list. For example (backquote-list* 'a 'b 'c) => (a b . c)" + ;; The recursive solution is much nicer: + ;; (if list (cons first (apply 'backquote-list*-function list)) first)) + ;; but Emacs is not very good at efficiently processing recursion. (if list (let* ((rest list) (newlist (cons first nil)) (last newlist)) (while (cdr rest) @@ -58,7 +61,10 @@ For example (backquote-list* 'a 'b 'c) => (a b . c)" "Like `list' but the last argument is the tail of the new list. For example (backquote-list* 'a 'b 'c) => (a b . c)" - (setq list (reverse (cons first list)) + ;; The recursive solution is much nicer: + ;; (if list (list 'cons first (cons 'backquote-list*-macro list)) first)) + ;; but Emacs is not very good at efficiently processing such things. + (setq list (nreverse (cons first list)) first (car list) list (cdr list)) (if list @@ -214,4 +220,5 @@ Vectors work just like lists. Nested backquotes are permitted." tail)) (t (cons 'list heads))))) +;;; arch-tag: 1a26206a-6b5e-4c56-8e24-2eef0f7e0e7a ;;; backquote.el ends here diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index cc8a7bf96f6..acf9806c519 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -114,4 +114,6 @@ non-interactive use see also `benchmark-run' and (nth 2 result) (nth 1 result))))) (provide 'benchmark) + +;;; arch-tag: be570e24-4b51-4784-adf3-fa2b56c31946 ;;; benchmark.el ends here diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 312d4b386b3..d8b4b4f6c19 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -619,4 +619,5 @@ If optional second arg SEP is a string, use that as separator." (provide 'bindat) +;;; arch-tag: 5e6708c3-03e2-4ad7-9885-5041b779c3fb ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 47cbec1fbc9..825df2526c0 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,6 +1,6 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -;;; Copyright (c) 1991, 1994, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (c) 1991,1994,2000,01,02,2004 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -148,37 +148,37 @@ ;; Other things to consider: -;;;;; Associative math should recognize subcalls to identical function: -;;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) -;;;;; This should generate the same as (1+ x) and (1- x) - -;;;(disassemble (lambda (x) (cons (+ x 1) (- x 1)))) -;;;;; An awful lot of functions always return a non-nil value. If they're -;;;;; error free also they may act as true-constants. - -;;;(disassemble (lambda (x) (and (point) (foo)))) -;;;;; When -;;;;; - all but one arguments to a function are constant -;;;;; - the non-constant argument is an if-expression (cond-expression?) -;;;;; then the outer function can be distributed. If the guarding -;;;;; condition is side-effect-free [assignment-free] then the other -;;;;; arguments may be any expressions. Since, however, the code size -;;;;; can increase this way they should be "simple". Compare: - -;;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) -;;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) - -;;;;; (car (cons A B)) -> (progn B A) -;;;(disassemble (lambda (x) (car (cons (foo) 42)))) - -;;;;; (cdr (cons A B)) -> (progn A B) -;;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) - -;;;;; (car (list A B ...)) -> (progn B ... A) -;;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) - -;;;;; (cdr (list A B ...)) -> (progn A (list B ...)) -;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) +;; ;; Associative math should recognize subcalls to identical function: +;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) +;; ;; This should generate the same as (1+ x) and (1- x) + +;; (disassemble (lambda (x) (cons (+ x 1) (- x 1)))) +;; ;; An awful lot of functions always return a non-nil value. If they're +;; ;; error free also they may act as true-constants. + +;; (disassemble (lambda (x) (and (point) (foo)))) +;; ;; When +;; ;; - all but one arguments to a function are constant +;; ;; - the non-constant argument is an if-expression (cond-expression?) +;; ;; then the outer function can be distributed. If the guarding +;; ;; condition is side-effect-free [assignment-free] then the other +;; ;; arguments may be any expressions. Since, however, the code size +;; ;; can increase this way they should be "simple". Compare: + +;; (disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) +;; (disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) + +;; ;; (car (cons A B)) -> (prog1 A B) +;; (disassemble (lambda (x) (car (cons (foo) 42)))) + +;; ;; (cdr (cons A B)) -> (progn A B) +;; (disassemble (lambda (x) (cdr (cons 42 (foo))))) + +;; ;; (car (list A B ...)) -> (prog1 A B ...) +;; (disassemble (lambda (x) (car (list (foo) 42 (bar))))) + +;; ;; (cdr (list A B ...)) -> (progn A (list B ...)) +;; (disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) ;;; Code: @@ -217,10 +217,8 @@ args))))) (defmacro byte-compile-log-lap (format-string &rest args) - (list 'and - '(memq byte-optimize-log '(t byte)) - (cons 'byte-compile-log-lap-1 - (cons format-string args)))) + `(and (memq byte-optimize-log '(t byte)) + (byte-compile-log-lap-1 ,format-string ,@args))) ;;; byte-compile optimizers to support inlining @@ -274,18 +272,18 @@ (let (string) (fetch-bytecode fn) (setq string (aref fn 1)) + ;; Isn't it an error for `string' not to be unibyte?? --stef (if (fboundp 'string-as-unibyte) (setq string (string-as-unibyte string))) - (cons (list 'lambda (aref fn 0) - (list 'byte-code string (aref fn 2) (aref fn 3))) + (cons `(lambda ,(aref fn 0) + (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) (if (eq (car-safe fn) 'lambda) (cons fn (cdr form)) ;; Give up on inlining. form)))))) -;;; ((lambda ...) ...) -;;; +;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) (or name (setq name "anonymous lambda")) (let ((lambda (car form)) @@ -604,14 +602,14 @@ (nreverse result))) -;;; some source-level optimizers -;;; -;;; when writing optimizers, be VERY careful that the optimizer returns -;;; something not EQ to its argument if and ONLY if it has made a change. -;;; This implies that you cannot simply destructively modify the list; -;;; you must return something not EQ to it if you make an optimization. -;;; -;;; It is now safe to optimize code such that it introduces new bindings. +;; some source-level optimizers +;; +;; when writing optimizers, be VERY careful that the optimizer returns +;; something not EQ to its argument if and ONLY if it has made a change. +;; This implies that you cannot simply destructively modify the list; +;; you must return something not EQ to it if you make an optimization. +;; +;; It is now safe to optimize code such that it introduces new bindings. ;; I'd like this to be a defsubst, but let's not be self-referential... (defmacro byte-compile-trueconstp (form) @@ -721,10 +719,10 @@ (condition-case () (eval form) (error form))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;; ((null (cdr (cdr form))) (nth 1 form)) +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). +;;; ((null (cdr (cdr form))) (nth 1 form)) ((null (cddr form)) (if (numberp (nth 1 form)) (nth 1 form) @@ -763,9 +761,9 @@ (numberp last)) (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) (delq last (copy-sequence (nthcdr 3 form)))))))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). ;;; (if (eq (nth 2 form) 0) ;;; (nth 1 form) ; (- x 0) --> x (byte-optimize-predicate @@ -780,9 +778,9 @@ (setq form (byte-optimize-delay-constants-math form 1 '*)) ;; If there is a constant in FORM, it is now the last element. (cond ((null (cdr form)) 1) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker or if it appears in other arithmetic). +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker or if it appears in other arithmetic). ;;; ((null (cdr (cdr form))) (nth 1 form)) ((let ((last (car (reverse form)))) (cond ((eq 0 last) (cons 'progn (cdr form))) @@ -1117,8 +1115,16 @@ (byte-optimize-predicate form)) form)) -(put 'concat 'byte-optimizer 'byte-optimize-concat) -(defun byte-optimize-concat (form) +(put 'concat 'byte-optimizer 'byte-optimize-pure-func) +(put 'symbol-name 'byte-optimizer 'byte-optimize-pure-func) +(put 'regexp-opt 'byte-optimizer 'byte-optimize-pure-func) +(put 'regexp-quote 'byte-optimizer 'byte-optimize-pure-func) +(defun byte-optimize-pure-func (form) + "Do constant folding for pure functions. +This assumes that the function will not have any side-effects and that +its return value depends solely on its arguments. +If the function can signal an error, this might change the semantics +of FORM by signalling the error at compile-time." (let ((args (cdr form)) (constant t)) (while (and args constant) @@ -1181,28 +1187,28 @@ `(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form)))) (t form)))) -;;; enumerating those functions which need not be called if the returned -;;; value is not used. That is, something like -;;; (progn (list (something-with-side-effects) (yow)) -;;; (foo)) -;;; may safely be turned into -;;; (progn (progn (something-with-side-effects) (yow)) -;;; (foo)) -;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. - -;;; Some of these functions have the side effect of allocating memory -;;; and it would be incorrect to replace two calls with one. -;;; But we don't try to do those kinds of optimizations, -;;; so it is safe to list such functions here. -;;; Some of these functions return values that depend on environment -;;; state, so that constant folding them would be wrong, -;;; but we don't do constant folding based on this list. - -;;; However, at present the only optimization we normally do -;;; is delete calls that need not occur, and we only do that -;;; with the error-free functions. - -;;; I wonder if I missed any :-\) +;; enumerating those functions which need not be called if the returned +;; value is not used. That is, something like +;; (progn (list (something-with-side-effects) (yow)) +;; (foo)) +;; may safely be turned into +;; (progn (progn (something-with-side-effects) (yow)) +;; (foo)) +;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. + +;; Some of these functions have the side effect of allocating memory +;; and it would be incorrect to replace two calls with one. +;; But we don't try to do those kinds of optimizations, +;; so it is safe to list such functions here. +;; Some of these functions return values that depend on environment +;; state, so that constant folding them would be wrong, +;; but we don't do constant folding based on this list. + +;; However, at present the only optimization we normally do +;; is delete calls that need not occur, and we only do that +;; with the error-free functions. + +;; I wonder if I missed any :-\) (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan assoc assq @@ -1303,8 +1309,8 @@ (defconst byte-constref-ops '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) -;;; This function extracts the bitfields from variable-length opcodes. -;;; Originally defined in disass.el (which no longer uses it.) +;; This function extracts the bitfields from variable-length opcodes. +;; Originally defined in disass.el (which no longer uses it.) (defun disassemble-offset () "Don't call this!" @@ -1341,11 +1347,11 @@ (aref bytes ptr)))) -;;; This de-compiler is used for inline expansion of compiled functions, -;;; and by the disassembler. -;;; -;;; This list contains numbers, which are pc values, -;;; before each instruction. +;; This de-compiler is used for inline expansion of compiled functions, +;; and by the disassembler. +;; +;; This list contains numbers, which are pc values, +;; before each instruction. (defun byte-decompile-bytecode (bytes constvec) "Turns BYTECODE into lapcode, referring to CONSTVEC." (let ((byte-compile-constants nil) @@ -1466,38 +1472,39 @@ byte-member byte-assq byte-quo byte-rem) byte-compile-side-effect-and-error-free-ops)) -;;; This crock is because of the way DEFVAR_BOOL variables work. -;;; Consider the code -;;; -;;; (defun foo (flag) -;;; (let ((old-pop-ups pop-up-windows) -;;; (pop-up-windows flag)) -;;; (cond ((not (eq pop-up-windows old-pop-ups)) -;;; (setq old-pop-ups pop-up-windows) -;;; ...)))) -;;; -;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is -;;; something else. But if we optimize -;;; -;;; varref flag -;;; varbind pop-up-windows -;;; varref pop-up-windows -;;; not -;;; to -;;; varref flag -;;; dup -;;; varbind pop-up-windows -;;; not -;;; -;;; we break the program, because it will appear that pop-up-windows and -;;; old-pop-ups are not EQ when really they are. So we have to know what -;;; the BOOL variables are, and not perform this optimization on them. - -;;; The variable `byte-boolean-vars' is now primitive and updated -;;; automatically by DEFVAR_BOOL. +;; This crock is because of the way DEFVAR_BOOL variables work. +;; Consider the code +;; +;; (defun foo (flag) +;; (let ((old-pop-ups pop-up-windows) +;; (pop-up-windows flag)) +;; (cond ((not (eq pop-up-windows old-pop-ups)) +;; (setq old-pop-ups pop-up-windows) +;; ...)))) +;; +;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is +;; something else. But if we optimize +;; +;; varref flag +;; varbind pop-up-windows +;; varref pop-up-windows +;; not +;; to +;; varref flag +;; dup +;; varbind pop-up-windows +;; not +;; +;; we break the program, because it will appear that pop-up-windows and +;; old-pop-ups are not EQ when really they are. So we have to know what +;; the BOOL variables are, and not perform this optimization on them. + +;; The variable `byte-boolean-vars' is now primitive and updated +;; automatically by DEFVAR_BOOL. (defun byte-optimize-lapcode (lap &optional for-effect) - "Simple peephole optimizer. LAP is both modified and returned." + "Simple peephole optimizer. LAP is both modified and returned. +If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (let (lap0 lap1 lap2 @@ -2030,4 +2037,5 @@ byte-optimize-lapcode)))) nil) +;;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 ;;; byte-opt.el ends here diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index a28f89cd91a..9956d5003cc 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,6 +1,6 @@ ;;; byte-run.el --- byte-compiler support for inlining -;; Copyright (C) 1992 Free Software Foundation, Inc. +;; Copyright (C) 1992, 2004 Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -67,14 +67,14 @@ ;; This has a special byte-hunk-handler in bytecomp.el. (defmacro defsubst (name arglist &rest body) "Define an inline function. The syntax is just like that of `defun'." + (declare (debug defun)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) - (list 'prog1 - (cons 'defun (cons name (cons arglist body))) - (list 'eval-and-compile - (list 'put (list 'quote name) - ''byte-optimizer ''byte-compile-inline-expand)))) + `(prog1 + (defun ,name ,arglist ,@body) + (eval-and-compile + (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) (defun make-obsolete (fn new &optional when) "Make the byte-compiler warn that FUNCTION is obsolete. @@ -91,9 +91,9 @@ was first made obsolete, for example a date or a release number." fn) (defun make-obsolete-variable (var new &optional when) - "Make the byte-compiler warn that VARIABLE is obsolete, -and NEW should be used instead. If NEW is a string, then that is the -`use instead' message. + "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. If provided, WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number." (interactive @@ -109,6 +109,7 @@ was first made obsolete, for example a date or a release number." (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). If you think you need this, you're probably making a mistake somewhere." + (declare (debug t)) (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) @@ -121,6 +122,7 @@ If you think you need this, you're probably making a mistake somewhere." (defmacro eval-when-compile (&rest body) "Like `progn', but evaluates the body at compile time. The result of the body appears to the compiler as a quoted constant." + (declare (debug t)) ;; Not necessary because we have it in b-c-initial-macro-environment ;; (list 'quote (eval (cons 'progn body))) (cons 'progn body)) @@ -128,6 +130,7 @@ The result of the body appears to the compiler as a quoted constant." (put 'eval-and-compile 'lisp-indent-hook 0) (defmacro eval-and-compile (&rest body) "Like `progn', but evaluates the body at compile time and at load time." + (declare (debug t)) ;; Remember, it's magic. (cons 'progn body)) @@ -169,4 +172,5 @@ The result of the body appears to the compiler as a quoted constant." ;; (file-format emacs19))" ;; nil) +;;; arch-tag: 76f8328a-1f66-4df2-9b6d-5c3666dc05e9 ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b9c864a6792..3e3bfe2a074 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,6 +1,6 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code -;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002, 2003 +;; Copyright (C) 1985,86,87,92,94,1998,2000,01,02,03,2004 ;; Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> @@ -8,10 +8,6 @@ ;; Maintainer: FSF ;; Keywords: lisp -;;; This version incorporates changes up to version 2.10 of the -;;; Zawinski-Furuseth compiler. -(defconst byte-compile-version "$Revision: 2.134 $") - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -75,7 +71,7 @@ ;; User customization variables: ;; ;; byte-compile-verbose Whether to report the function currently being -;; compiled in the minibuffer; +;; compiled in the echo area; ;; byte-optimize Whether to do optimizations; this may be ;; t, nil, 'source, or 'byte; ;; byte-optimize-log Whether to report (in excruciating detail) @@ -130,7 +126,7 @@ ;; (baz 0)) ;; ;; o It is possible to open-code a function in the same file it is defined -;; in without having to load that file before compiling it. the +;; in without having to load that file before compiling it. The ;; byte-compiler has been modified to remember function definitions in ;; the compilation environment in the same way that it remembers macro ;; definitions. @@ -251,7 +247,9 @@ if you change this variable." :type 'boolean) (defcustom byte-compile-compatibility nil - "*Non-nil means generate output that can run in Emacs 18." + "*Non-nil means generate output that can run in Emacs 18. +This only means that it can run in principle, if it doesn't require +facilities that have been added more recently." :group 'bytecomp :type 'boolean) @@ -351,6 +349,9 @@ Elements of the list may be be: (const callargs) (const redefine) (const obsolete) (const noruntime) (const cl-functions)))) +(defvar byte-compile-not-obsolete-var nil + "If non-nil, this is a variable that shouldn't be reported as obsolete.") + (defcustom byte-compile-generate-call-tree nil "*Non-nil means collect call-graph information when compiling. This records functions were called and from where. @@ -441,6 +442,11 @@ Each element looks like (FUNCTIONNAME . DEFINITION). It is Used for warnings when the function is not known to be defined or is later defined with incorrect args.") +(defvar byte-compile-noruntime-functions nil + "Alist of functions called that may not be defined when the compiled code is run. +Used for warnings about calling a function that is defined during compilation +but won't necessarily be defined when the compiled file is loaded.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -773,7 +779,7 @@ otherwise pop it") (defun byte-compile-eval (form) "Eval FORM and mark the functions defined therein. -Each function's symbol gets marked with the `byte-compile-noruntime' property." +Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((hist-orig load-history) (hist-nil-orig current-load-list)) (prog1 (eval form) @@ -791,17 +797,17 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." (cond ((symbolp s) (unless (memq s old-autoloads) - (put s 'byte-compile-noruntime t))) + (push s byte-compile-noruntime-functions))) ((and (consp s) (eq t (car s))) (push (cdr s) old-autoloads)) ((and (consp s) (eq 'autoload (car s))) - (put (cdr s) 'byte-compile-noruntime t))))))) + (push (cdr s) byte-compile-noruntime-functions))))))) ;; Go through current-load-list for the locally defined funs. (let (old-autoloads) (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig))) (let ((s (pop hist-nil-new))) (when (and (symbolp s) (not (memq s old-autoloads))) - (put s 'byte-compile-noruntime t)) + (push s byte-compile-noruntime-functions)) (when (and (consp s) (eq t (car s))) (push (cdr s) old-autoloads)))))))))) @@ -926,7 +932,7 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." (when (or (and byte-compile-current-file (not (equal byte-compile-current-file byte-compile-last-logged-file))) - (and byte-compile-last-warned-form + (and byte-compile-current-form (not (eq byte-compile-current-form byte-compile-last-warned-form)))) (insert (format "\nIn %s:\n" form))) @@ -972,7 +978,8 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." (setq default-directory dir) (unless was-same (insert (format "Entering directory `%s'\n" default-directory)))) - (setq byte-compile-last-logged-file byte-compile-current-file) + (setq byte-compile-last-logged-file byte-compile-current-file + byte-compile-last-warned-form nil) ;; Do this after setting default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) @@ -982,7 +989,7 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." ;; 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-group-format "") + (warning-type-format "") (warning-fill-prefix (if fill " "))) (display-warning 'bytecomp string level "*Compile-Log*"))) @@ -1166,10 +1173,11 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." "requires" "accepts only") (byte-compile-arglist-signature-string sig)))) + (byte-compile-format-warn form) ;; Check to see if the function will be available at runtime ;; and/or remember its arity if it's unknown. (or (and (or sig (fboundp (car form))) ; might be a subr or autoload. - (not (get (car form) 'byte-compile-noruntime))) + (not (memq (car form) byte-compile-noruntime-functions))) (eq (car form) byte-compile-current-form) ; ## this doesn't work ; with recursion. ;; It's a currently-undefined function. @@ -1183,6 +1191,32 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." (cons (list (car form) n) byte-compile-unresolved-functions))))))) +(defun byte-compile-format-warn (form) + "Warn if FORM is `format'-like with inconsistent args. +Applies if head of FORM is a symbol with non-nil property +`byte-compile-format-like' and first arg is a constant string. +Then check the number of format fields matches the number of +extra args." + (when (and (symbolp (car form)) + (stringp (nth 1 form)) + (get (car form) 'byte-compile-format-like)) + (let ((nfields (with-temp-buffer + (insert (nth 1 form)) + (goto-char 1) + (let ((n 0)) + (while (re-search-forward "%." nil t) + (unless (eq ?% (char-after (1+ (match-beginning 0)))) + (setq n (1+ n)))) + n))) + (nargs (- (length form) 2))) + (unless (= nargs nfields) + (byte-compile-warn + "`%s' called with %d args to fill %d format field(s)" (car form) + nargs nfields))))) + +(dolist (elt '(format message error)) + (put elt 'byte-compile-format-like t)) + ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (form macrop) @@ -1250,7 +1284,7 @@ Each function's symbol gets marked with the `byte-compile-noruntime' property." (let ((func (car-safe form))) (if (and byte-compile-cl-functions (memq func byte-compile-cl-functions) - ;; Aliases which won't have been expended at this point. + ;; Aliases which won't have been expanded at this point. ;; These aren't all aliases of subrs, so not trivial to ;; avoid hardwiring the list. (not (memq func @@ -1455,7 +1489,8 @@ recompile every `.el' file that already has a `.elc' file." source dest) (dolist (file files) (setq source (expand-file-name file directory)) - (if (and (not (member file '("." ".." "RCS" "CVS"))) + (if (and (not (member file '("RCS" "CVS"))) + (not (eq ?\. (aref file 0))) (file-directory-p source) (not (file-symlink-p source))) ;; This file is a subdirectory. Handle them differently. @@ -1573,11 +1608,14 @@ The value is non-nil if there were no errors, nil if errors." ;; compile this file. (if (with-current-buffer input-buffer no-byte-compile) (progn - (message "%s not compiled because of `no-byte-compile: %s'" - (file-relative-name filename) - (with-current-buffer input-buffer no-byte-compile)) - (if (file-exists-p target-file) - (condition-case nil (delete-file target-file) (error nil))) + ;; (message "%s not compiled because of `no-byte-compile: %s'" + ;; (file-relative-name filename) + ;; (with-current-buffer input-buffer no-byte-compile)) + (when (file-exists-p target-file) + (message "%s deleted because of `no-byte-compile: %s'" + (file-relative-name target-file) + (buffer-local-value 'no-byte-compile input-buffer)) + (condition-case nil (delete-file target-file) (error nil))) ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose @@ -1654,7 +1692,7 @@ The value is non-nil if there were no errors, nil if errors." ;;;###autoload (defun compile-defun (&optional arg) "Compile and evaluate the current top-level form. -Print the result in the minibuffer. +Print the result in the echo area. With argument, insert value in current buffer after the form." (interactive "P") (save-excursion @@ -1818,10 +1856,7 @@ With argument, insert value in current buffer after the form." " on " (current-time-string) "\n;;; from file " filename "\n") (insert ";;; in Emacs version " emacs-version "\n") - (insert ";;; with bytecomp version " - (progn (string-match "[0-9.]+" byte-compile-version) - (match-string 0 byte-compile-version)) - "\n;;; " + (insert ";;; " (cond ((eq byte-optimize 'source) "with source-level optimization only") ((eq byte-optimize 'byte) "with byte-level optimization only") @@ -2449,17 +2484,19 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (cdr (cdr int)) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))) - ;; If the interactive spec is a call to `list', - ;; don't compile it, because `call-interactively' - ;; looks at the args of `list'. + ;; If the interactive spec is a call to `list', don't + ;; compile it, because `call-interactively' looks at the + ;; args of `list'. Actually, compile it to get warnings, + ;; but don't use the result. (let ((form (nth 1 int))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (or (eq (car-safe form) 'list) - (setq int (list 'interactive - (byte-compile-top-level (nth 1 int))))))) + (if (eq (car-safe form) 'list) + (byte-compile-top-level (nth 1 int)) + (setq int (list 'interactive + (byte-compile-top-level (nth 1 int))))))) ((cdr int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) @@ -2705,7 +2742,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp var) "constant" "nonvariable") (prin1-to-string var)) (if (and (get var 'byte-obsolete-variable) - (memq 'obsolete byte-compile-warnings)) + (memq 'obsolete byte-compile-warnings) + (not (eq var byte-compile-not-obsolete-var))) (let* ((ob (get var 'byte-obsolete-variable)) (when (cdr ob))) (byte-compile-warn "%s is an obsolete variable%s; %s" var @@ -2735,7 +2773,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) - (assoc ,const byte-compile-constants) + (assoc-default ,const byte-compile-constants + 'equal-including-properties nil) (assq ,const byte-compile-constants)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants))))) @@ -3262,51 +3301,55 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) ,tag)) +(defmacro byte-compile-maybe-guarded (condition &rest body) + "Execute forms in BODY, potentially guarded by CONDITION. +CONDITION is the test in an `if' form or in a `cond' clause. +BODY is to compile the first arm of the if or the body of the +cond clause. If CONDITION is of the form `(foundp 'foo)' +or `(boundp 'foo)', the relevant warnings from BODY about foo +being undefined will be suppressed." + (declare (indent 1) (debug t)) + `(let* ((fbound + (if (eq 'fboundp (car-safe ,condition)) + (and (eq 'quote (car-safe (nth 1 ,condition))) + ;; Ignore if the symbol is already on the + ;; unresolved list. + (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol + byte-compile-unresolved-functions)) + (nth 1 (nth 1 ,condition))))) + (bound (if (or (eq 'boundp (car-safe ,condition)) + (eq 'default-boundp (car-safe ,condition))) + (and (eq 'quote (car-safe (nth 1 ,condition))) + (nth 1 (nth 1 ,condition))))) + ;; Maybe add to the bound list. + (byte-compile-bound-variables + (if bound + (cons bound byte-compile-bound-variables) + byte-compile-bound-variables))) + (progn ,@body) + ;; Maybe remove the function symbol from the unresolved list. + (if fbound + (setq byte-compile-unresolved-functions + (delq (assq fbound byte-compile-unresolved-functions) + byte-compile-unresolved-functions))))) + (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) ;; Check whether we have `(if (fboundp ...' or `(if (boundp ...' ;; and avoid warnings about the relevent symbols in the consequent. - (let* ((clause (nth 1 form)) - (fbound (if (eq 'fboundp (car-safe clause)) - (and (eq 'quote (car-safe (nth 1 clause))) - ;; Ignore if the symbol is already on the - ;; unresolved list. - (not (assq - (nth 1 (nth 1 clause)) ; the relevant symbol - byte-compile-unresolved-functions)) - (nth 1 (nth 1 clause))))) - (bound (if (eq 'boundp (car-safe clause)) - (and (eq 'quote (car-safe (nth 1 clause))) - (nth 1 (nth 1 clause))))) - (donetag (byte-compile-make-tag))) + (let ((clause (nth 1 form)) + (donetag (byte-compile-make-tag))) (if (null (nthcdr 3 form)) ;; No else-forms (progn (byte-compile-goto-if nil for-effect donetag) - ;; Maybe add to the bound list. - (let ((byte-compile-bound-variables - (if bound - (cons bound byte-compile-bound-variables) - byte-compile-bound-variables))) + (byte-compile-maybe-guarded clause (byte-compile-form (nth 2 form) for-effect)) - ;; Maybe remove the function symbol from the unresolved list. - (if fbound - (setq byte-compile-unresolved-functions - (delq (assq fbound byte-compile-unresolved-functions) - byte-compile-unresolved-functions))) (byte-compile-out-tag donetag)) (let ((elsetag (byte-compile-make-tag))) (byte-compile-goto 'byte-goto-if-nil elsetag) - ;; As above for the first form. - (let ((byte-compile-bound-variables - (if bound - (cons bound byte-compile-bound-variables) - byte-compile-bound-variables))) - (byte-compile-form (nth 2 form) for-effect)) - (if fbound - (setq byte-compile-unresolved-functions - (delq (assq fbound byte-compile-unresolved-functions) - byte-compile-unresolved-functions))) + (byte-compile-maybe-guarded clause + (byte-compile-form (nth 2 form) for-effect)) (byte-compile-goto 'byte-goto donetag) (byte-compile-out-tag elsetag) (byte-compile-body (cdr (cdr (cdr form))) for-effect) @@ -3329,17 +3372,20 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (null (cdr clause)) ;; First clause is a singleton. (byte-compile-goto-if t for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-body (cdr clause) for-effect) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-maybe-guarded (car clause) + (byte-compile-body (cdr clause) for-effect)) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag))))) ;; Last clause - (and (cdr clause) (not (eq (car clause) t)) - (progn (byte-compile-form (car clause)) - (byte-compile-goto-if nil for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-body-do-effect clause) + (let ((guard (car clause))) + (and (cdr clause) (not (eq guard t)) + (progn (byte-compile-form guard) + (byte-compile-goto-if nil for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-maybe-guarded guard + (byte-compile-body-do-effect clause))) (byte-compile-out-tag donetag))) (defun byte-compile-and (form) @@ -3610,13 +3656,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." fun var string)) `(put ',var 'variable-documentation ,string)) (if (cddr form) ; `value' provided - (if (eq fun 'defconst) - ;; `defconst' sets `var' unconditionally. - (let ((tmp (make-symbol "defconst-tmp-var"))) - `(funcall '(lambda (,tmp) (defconst ,var ,tmp)) - ,value)) - ;; `defvar' sets `var' only when unbound. - `(if (not (default-boundp ',var)) (setq-default ,var ,value))) + (let ((byte-compile-not-obsolete-var var)) + (if (eq fun 'defconst) + ;; `defconst' sets `var' unconditionally. + (let ((tmp (make-symbol "defconst-tmp-var"))) + `(funcall '(lambda (,tmp) (defconst ,var ,tmp)) + ,value)) + ;; `defvar' sets `var' only when unbound. + `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. `(eval ',form))) @@ -3921,27 +3968,29 @@ already up-to-date." (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) - (condition-case err + (if debug-on-error (byte-compile-file file) - (file-error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" + (condition-case err + (byte-compile-file file) + (file-error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - (let ((destfile (byte-compile-dest-file file))) - (if (file-exists-p destfile) - (delete-file destfile))) - nil) - (error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) + nil) + (error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - nil))) + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + nil)))) ;;;###autoload (defun batch-byte-recompile-directory () @@ -4036,4 +4085,5 @@ For example, invoke `emacs -batch -f batch-byte-recompile-directory .'." (run-hooks 'bytecomp-load-hook) +;;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a ;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index a5fb3cede5e..fddab94dfd4 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1,6 +1,6 @@ ;;; checkdoc.el --- check documentation strings for style requirements -;;; Copyright (C) 1997, 1998, 2001 Free Software Foundation +;;; Copyright (C) 1997, 1998, 2001, 2004 Free Software Foundation ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Version: 0.6.2 @@ -653,8 +653,7 @@ style." (sit-for 2)) (setq err-list (cdr err-list)))) (beginning-of-defun) - (let ((pe (car err-list)) - (ne (funcall findfunc nil))) + (let ((ne (funcall findfunc nil))) (if ne (setq err-list (cons ne err-list)) (cond ((not err-list) @@ -900,7 +899,7 @@ Prefix argument TAKE-NOTES means to continue through the whole buffer and save warnings in a separate buffer. Second optional argument START-POINT is the starting location. If this is nil, `point-min' is used instead." (interactive "P") - (let ((wrong nil) (msg nil) (errors nil) + (let ((wrong nil) (msg nil) ;; Assign a flag to spellcheck flag (checkdoc-spellcheck-documentation-flag (car (memq checkdoc-spellcheck-documentation-flag @@ -2598,14 +2597,13 @@ This function will not modify `match-data'." (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-mouse)) + '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 -\\[checkdoc-find-error-mouse] - Goto the error clicked on." +\\<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 @@ -2619,16 +2617,11 @@ This function will not modify `match-data'." (run-hooks 'checkdoc-output-mode-hook) (current-buffer)))) -(defun checkdoc-find-error-mouse (e) - ;; checkdoc-params: (e) - "Call `checkdoc-find-error' where the user clicks the mouse." - (interactive "e") - (mouse-set-point e) - (checkdoc-find-error)) - -(defun checkdoc-find-error () +(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) + (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))) @@ -2657,7 +2650,7 @@ function called to create the messages." (setq checkdoc-pending-errors t) (checkdoc-output-to-error-buffer "\n" (checkdoc-buffer-label) ":" - (int-to-string (count-lines (point-min) (or point 1))) ": " + (int-to-string (count-lines (point-min) (or point (point-min)))) ": " msg)) (defun checkdoc-output-to-error-buffer (&rest text) @@ -2692,8 +2685,11 @@ function called to create the messages." (add-to-list 'debug-ignored-errors "Argument `.*' should appear (as .*) in the doc string") +(add-to-list 'debug-ignored-errors + "Lisp symbol `.*' should appear in quotes") (add-to-list 'debug-ignored-errors "Disambiguate .* by preceding .*") (provide 'checkdoc) +;;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26 ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-compat.el b/lisp/emacs-lisp/cl-compat.el index 9afe4fe426a..c3fbbe0993b 100644 --- a/lisp/emacs-lisp/cl-compat.el +++ b/lisp/emacs-lisp/cl-compat.el @@ -185,4 +185,5 @@ (provide 'cl-compat) +;;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163 ;;; cl-compat.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index b0b8d3379f2..bfd21e27d05 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -749,4 +749,5 @@ This also does some trivial optimizations to make the form prettier." (run-hooks 'cl-extra-load-hook) +;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed ;;; cl-extra.el ends here diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 485a0522952..2e6265d4dfd 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -605,4 +605,5 @@ If nil, indent backquoted lists as data, i.e., like quoted lists." ;(put 'defclass 'common-lisp-indent-function '((&whole 2 &rest (&whole 2 &rest 1) &rest (&whole 2 &rest 1))) ;(put 'defgeneric 'common-lisp-indent-function 'defun) +;;; arch-tag: 7914d50f-92ec-4476-93fc-0f043a380e03 ;;; cl-indent.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index fc1d6ffef0a..c61c275f2b0 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,6 +1,6 @@ ;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- -;; Copyright (C) 1993, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Version: 2.02 @@ -2261,8 +2261,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. (list (list 'or pred-check (list 'error (format "%s accessing a non-%s" - accessor name) - 'cl-x)))) + accessor name))))) (list (if (eq type 'vector) (list 'aref 'cl-x pos) (if (= pos 0) '(car cl-x) (list 'nth pos 'cl-x)))))) forms) @@ -2340,8 +2339,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. (list (list 'or (subst temp 'cl-x pred-form) (list 'error (format - "%s storing a non-%s" accessor name) - temp)))) + "%s storing a non-%s" accessor name))))) (list (if (eq (car (get name 'cl-struct-type)) 'vector) (list 'aset temp pos store) (list 'setcar @@ -2657,4 +2655,5 @@ surrounded by (block NAME ...). ;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) ;;; End: +;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 8cb6412f774..93237f0206f 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -903,4 +903,5 @@ Keywords supported: :test :test-not :key" (run-hooks 'cl-seq-load-hook) +;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el index 077f006ec3b..97c7d67ac53 100644 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@ -7,7 +7,6 @@ ;; LCD Archive Entry: ;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org ;; |Edebug specs for cl.el -;; |$Date: 2003/02/04 12:53:34 $|1.1| ;; This file is part of GNU Emacs. @@ -470,4 +469,5 @@ (def-edebug-spec loop-d-type-spec (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) +;;; arch-tag: b29aa3c2-cf67-4af8-9ee1-318fea61b478 ;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index f2ced20e59e..b098a467f9f 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -108,6 +108,10 @@ printer proceeds to the next function on the list. This variable is not used at present, but it is defined in hopes that a future Emacs interpreter will be able to use it.") +(defvar cl-unload-hook '(cl-cannot-unload) + "Prevent unloading the feature `cl', since it does not work.") +(defun cl-cannot-unload () + (error "Cannot unload the feature `cl'")) ;;; Predicates. @@ -579,9 +583,10 @@ Keywords supported: :test :test-not :key" "Non-nil means don't make CL functions autoload.") ;;; Autoload the other portions of the package. -;; We want to replace the basic versions of dolist, dotimes below. +;; We want to replace the basic versions of dolist, dotimes, declare below. (fmakunbound 'dolist) (fmakunbound 'dotimes) +(fmakunbound 'declare) (mapcar (function (lambda (set) (let ((file (if cl-fake-autoloads "<none>" (car set)))) @@ -695,4 +700,5 @@ Keywords supported: :test :test-not :key" (run-hooks 'cl-load-hook) +;;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 43b32e42d2e..58ab919c2f9 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -1,6 +1,6 @@ ;;; copyright.el --- update the copyright notice in current buffer -;; Copyright (C) 1991, 92, 93, 94, 95, 1998, 2001, 2003 +;; Copyright (C) 1991, 92, 93, 94, 95, 1998, 2001, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> @@ -27,7 +27,8 @@ ;; Allows updating the copyright year and above mentioned GPL version manually ;; or when saving a file. -;; Do (add-hook 'write-file-functions 'copyright-update). +;; Do (add-hook 'before-save-hook 'copyright-update), or use +;; M-x customize-variable RET before-save-hook RET. ;;; Code: @@ -189,4 +190,5 @@ version \\([0-9]+\\), or (at" ;; coding: utf-8 ;; End: +;;; arch-tag: b4991afb-b6b1-4590-bebe-e076d9d4aee8 ;;; copyright.el ends here diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 46293bf94f3..572c658d0fc 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -629,4 +629,5 @@ INHERIT-INPUT-METHOD." (provide 'crm) +;;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6 ;;; crm.el ends here diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el index a8cf6acd177..929989b618a 100644 --- a/lisp/emacs-lisp/cust-print.el +++ b/lisp/emacs-lisp/cust-print.el @@ -688,4 +688,5 @@ See `custom-format' for the details." (provide 'cust-print) +;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580 ;;; cust-print.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 10c4fd4f734..6e10b596e23 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -733,4 +733,5 @@ If argument is nil or an empty string, cancel for all functions." (provide 'debug) +;;; arch-tag: b6ec7047-f801-4103-9c63-d69322db9d3b ;;; debug.el ends here diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 4aa85290801..811511a1f00 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -437,4 +437,5 @@ Where the new table already has an entry, nothing is copied from the old one." (provide 'derived) +;;; arch-tag: 630be248-47d1-4f02-afa0-8207de0ebea0 ;;; derived.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 6b7f9bc1b3e..d8890bd0239 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -265,4 +265,5 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (provide 'disass) +;;; arch-tag: 89482fe4-a087-4761-8dc6-d771054e763a ;;; disass.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 9175f692aae..2439fdd4de6 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -1,6 +1,6 @@ ;;; easy-mmode.el --- easy definition for major and minor modes -;; Copyright (C) 1997, 2000, 2001, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1997,2000,01,02,03,2004 Free Software Foundation, Inc. ;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> ;; Maintainer: Stefan Monnier <monnier@gnu.org> @@ -419,7 +419,7 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." ;;; easy-mmode-define-navigation ;;; -(defmacro easy-mmode-define-navigation (base re &optional name endfun) +(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun) "Define BASE-next and BASE-prev to navigate in the buffer. RE determines the places the commands should move point to. NAME should describe the entities matched by RE. It is used to build @@ -427,10 +427,19 @@ NAME should describe the entities matched by RE. It is used to build BASE-next also tries to make sure that the whole entry is visible by searching for its end (by calling ENDFUN if provided or by looking for the next entry) and recentering if necessary. -ENDFUN should return the end position (with or without moving point)." +ENDFUN should return the end position (with or without moving point). +NARROWFUN non-nil means to check for narrowing before moving, and if +found, do widen first and then call NARROWFUN with no args after moving." (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) - (next-sym (intern (concat base-name "-next")))) + (next-sym (intern (concat base-name "-next"))) + (check-narrow-maybe + (when narrowfun + '(setq was-narrowed + (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) + (widen))))) + (re-narrow-maybe (when narrowfun + `(when was-narrowed (,narrowfun))))) (unless name (setq name base-name)) `(progn (add-to-list 'debug-ignored-errors @@ -440,28 +449,36 @@ ENDFUN should return the end position (with or without moving point)." (interactive) (unless count (setq count 1)) (if (< count 0) (,prev-sym (- count)) - (if (looking-at ,re) (incf count)) - (if (not (re-search-forward ,re nil t count)) - (if (looking-at ,re) - (goto-char (or ,(if endfun `(,endfun)) (point-max))) - (error "No next %s" ,name)) - (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer (selected-window))) - (interactive-p)) - (let ((endpt (or (save-excursion - ,(if endfun `(,endfun) - `(re-search-forward ,re nil t 2))) - (point-max)))) - (unless (pos-visible-in-window-p endpt nil t) - (recenter '(0)))))))) + (if (looking-at ,re) (setq count (1+ count))) + (let (was-narrowed) + ,check-narrow-maybe + (if (not (re-search-forward ,re nil t count)) + (if (looking-at ,re) + (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (error "No next %s" ,name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer (selected-window))) + (interactive-p)) + (let ((endpt (or (save-excursion + ,(if endfun `(,endfun) + `(re-search-forward ,re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (recenter '(0)))))) + ,re-narrow-maybe))) (defun ,prev-sym (&optional count) ,(format "Go to the previous COUNT'th %s" (or name base-name)) (interactive) (unless count (setq count 1)) (if (< count 0) (,next-sym (- count)) - (unless (re-search-backward ,re nil t count) - (error "No previous %s" ,name))))))) + (let (was-narrowed) + ,check-narrow-maybe + (unless (re-search-backward ,re nil t count) + (error "No previous %s" ,name)) + ,re-narrow-maybe)))))) + (provide 'easy-mmode) +;;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 2bed70866a1..88f7657b6bf 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,6 +1,6 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu -;; Copyright (C) 1994, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1994,96,98,1999,2000,2004 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: Richard Stallman <rms@gnu.org> @@ -59,8 +59,8 @@ It may be followed by the following keyword argument pairs :filter FUNCTION -FUNCTION is a function with one argument, the menu. It returns the actual -menu displayed. +FUNCTION is a function with one argument, the rest of menu items. +It returns the remaining items of the displayed menu. :visible INCLUDE @@ -478,7 +478,9 @@ 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))) - (if (keymapp menu) (x-popup-menu nil menu)))) + ;; x-popup-menu does not exist on tty-only Emacs. + ;; (if (keymapp menu) (x-popup-menu nil menu)) + )) (defun add-submenu (menu-path submenu &optional before in-menu) "Add submenu SUBMENU in the menu at MENU-PATH. @@ -620,4 +622,5 @@ In some cases we use that to select between the local and global maps." (provide 'easymenu) +;;; arch-tag: 2a04020d-90d2-476d-a7c6-71e072007a4a ;;; easymenu.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 8fd8bf95ea9..8a924d045f7 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1,6 +1,6 @@ ;;; edebug.el --- a source-level debugger for Emacs Lisp -;; Copyright (C) 1988, 89, 90, 91, 92, 93, 94, 95, 97, 1999, 2000, 01, 2003 +;; Copyright (C) 1988,89,90,91,92,93,94,95,97,1999,2000,01,03,2004 ;; Free Software Foundation, Inc. ;; Author: Daniel LaLiberte <liberte@holonexus.org> @@ -2090,6 +2090,10 @@ expressions; a `progn' form will be returned enclosing these forms." (def-edebug-spec push (form sexp)) (def-edebug-spec pop (sexp)) +(def-edebug-spec 1value (form)) +(def-edebug-spec noreturn (form)) + + ;; Anything else? @@ -2241,8 +2245,10 @@ error is signaled again." ;; Save the outside value of executing macro. (here??) (edebug-outside-executing-macro executing-kbd-macro) - (edebug-outside-pre-command-hook pre-command-hook) - (edebug-outside-post-command-hook post-command-hook)) + (edebug-outside-pre-command-hook + (edebug-var-status 'pre-command-hook)) + (edebug-outside-post-command-hook + (edebug-var-status 'post-command-hook))) (unwind-protect (let (;; Don't keep reading from an executing kbd macro ;; within edebug unless edebug-continue-kbd-macro is @@ -2267,10 +2273,11 @@ error is signaled again." edebug-next-execution-mode nil) (edebug-enter edebug-function edebug-args edebug-body)) ;; Reset global variables in case outside value was changed. - (setq executing-kbd-macro edebug-outside-executing-macro - pre-command-hook edebug-outside-pre-command-hook - post-command-hook edebug-outside-post-command-hook - ))) + (setq executing-kbd-macro edebug-outside-executing-macro) + (edebug-restore-status + 'post-command-hook edebug-outside-post-command-hook) + (edebug-restore-status + 'pre-command-hook edebug-outside-pre-command-hook))) (let* ((edebug-data (get edebug-function 'edebug)) (edebug-def-mark (car edebug-data)) ; mark at def start @@ -2291,6 +2298,30 @@ error is signaled again." (funcall edebug-body)) ))) +(defun edebug-var-status (var) + "Return a cons cell describing the status of VAR's current binding. +The purpose of this function is so you can properly undo +subsequent changes to the same binding, by passing the status +cons cell to `edebug-restore-status'. The status cons cell +has the form (LOCUS . VALUE), where LOCUS can be a buffer +\(for a buffer-local binding), a frame (for a frame-local binding), +or nil (if the default binding is current)." + (cons (variable-binding-locus var) + (symbol-value var))) + +(defun edebug-restore-status (var status) + "Reset VAR based on STATUS. +STATUS should be a list you got from `edebug-var-status'." + (let ((locus (car status)) + (value (cdr status))) + (cond ((bufferp locus) + (if (buffer-live-p locus) + (with-current-buffer locus + (set var value)))) + ((framep locus) + (modify-frame-parameters locus (list (cons var value)))) + (t + (set var value))))) (defun edebug-enter-trace (edebug-body) (let ((edebug-stack-depth (1+ edebug-stack-depth)) @@ -2478,6 +2509,11 @@ MSG is printed after `::::} '." (defun edebug-display () + (unless (marker-position edebug-def-mark) + ;; The buffer holding the source has been killed. + ;; Let's at least show a backtrace so the user can figure out + ;; which function we're talking about. + (debug)) ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. ;; Uses local variables of edebug-enter, edebug-before, edebug-after ;; and edebug-debugger. @@ -3511,8 +3547,9 @@ Return the result of the last expression." (executing-kbd-macro edebug-outside-executing-macro) (defining-kbd-macro edebug-outside-defining-kbd-macro) - (pre-command-hook edebug-outside-pre-command-hook) - (post-command-hook edebug-outside-post-command-hook) + ;; Get the values out of the saved statuses. + (pre-command-hook (cdr edebug-outside-pre-command-hook)) + (post-command-hook (cdr edebug-outside-post-command-hook)) ;; See edebug-display (overlay-arrow-position edebug-outside-o-a-p) @@ -3552,13 +3589,18 @@ Return the result of the last expression." edebug-outside-executing-macro executing-kbd-macro edebug-outside-defining-kbd-macro defining-kbd-macro - edebug-outside-pre-command-hook pre-command-hook - edebug-outside-post-command-hook post-command-hook edebug-outside-o-a-p overlay-arrow-position edebug-outside-o-a-s overlay-arrow-string edebug-outside-c-i-e-a cursor-in-echo-area - ))) ; let + ) + + ;; Restore the outside saved values; don't alter + ;; the outside binding loci. + (setcdr edebug-outside-pre-command-hook pre-command-hook) + (setcdr edebug-outside-post-command-hook post-command-hook) + + )) ; let )) (defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used. @@ -3644,17 +3686,14 @@ Return the result of the last expression." (edebug-prin1-to-string value))) (defun edebug-compute-previous-result (edebug-previous-value) + (if edebug-unwrap-results + (setq edebug-previous-value + (edebug-unwrap* edebug-previous-value))) (setq edebug-previous-result - (if (and (integerp edebug-previous-value) - (< edebug-previous-value 256) - (>= edebug-previous-value 0)) - (format "Result: %s = %s" edebug-previous-value - (single-key-description edebug-previous-value)) - (if edebug-unwrap-results - (setq edebug-previous-value - (edebug-unwrap* edebug-previous-value))) - (concat "Result: " - (edebug-safe-prin1-to-string edebug-previous-value))))) + (concat "Result: " + (edebug-safe-prin1-to-string edebug-previous-value) + (let ((name (prin1-char edebug-previous-value))) + (if name (concat " = " name)))))) (defun edebug-previous-result () "Print the previous result." @@ -3676,14 +3715,13 @@ Print result in minibuffer." (edebug-safe-prin1-to-string (car values))))) (defun edebug-eval-last-sexp () - "Evaluate sexp before point in the outside environment; -print value in minibuffer." + "Evaluate sexp before point in the outside environment; value in minibuffer." (interactive) (edebug-eval-expression (edebug-last-sexp))) (defun edebug-eval-print-last-sexp () - "Evaluate sexp before point in the outside environment; -print value into current buffer." + "Evaluate sexp before point in the outside environment; insert the value. +This prints the value into current buffer." (interactive) (let* ((edebug-form (edebug-last-sexp)) (edebug-result-string @@ -3698,12 +3736,15 @@ print value into current buffer." ;;; Edebug Minor Mode -;; Global GUD bindings for all emacs-lisp-mode buffers. -(define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) -(define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) +(defvar gud-inhibit-global-bindings + "*Non-nil means don't do global rebindings of C-x C-a subcommands.") +;; Global GUD bindings for all emacs-lisp-mode buffers. +(unless gud-inhibit-global-bindings + (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)) (defvar edebug-mode-map (let ((map (copy-keymap emacs-lisp-mode-map))) @@ -4110,8 +4151,8 @@ You must include newlines in FMT to break lines, but one newline is appended." ;;; Frequency count and coverage (defun edebug-display-freq-count () - "Display the frequency count data for each line of the current -definition. The frequency counts are inserted as comment lines after + "Display the frequency count data for each line of the current definition. +The frequency counts are inserted as comment lines after each line, and you can undo all insertions with one `undo' command. The counts are inserted starting under the `(' before an expression @@ -4415,4 +4456,5 @@ 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/eldoc.el b/lisp/emacs-lisp/eldoc.el index cbcd5b2a555..bc868759d92 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -7,8 +7,6 @@ ;; Keywords: extensions ;; Created: 1995-10-06 -;; $Id: eldoc.el,v 1.24 2003/02/11 00:11:55 monnier Exp $ - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -40,11 +38,14 @@ ;; One useful way to enable this minor mode is to put the following in your ;; .emacs: ;; -;; (autoload 'turn-on-eldoc-mode "eldoc" nil t) ;; (add-hook 'emacs-lisp-mode-hook 'turn-on-eldoc-mode) ;; (add-hook 'lisp-interaction-mode-hook 'turn-on-eldoc-mode) ;; (add-hook 'ielm-mode-hook 'turn-on-eldoc-mode) +;; Major modes for other languages may use Eldoc by defining an +;; appropriate function as the buffer-local value of +;; `eldoc-print-current-symbol-info-function'. + ;;; Code: (require 'help-fns) ;For fundoc-usage handling functions. @@ -233,19 +234,32 @@ With prefix ARG, turn ElDoc mode on if and only if ARG is positive." (not (eq (selected-window) (minibuffer-window))))) +(defvar eldoc-print-current-symbol-info-function nil + "If non-nil, function to call to return doc string. +The function of no args should return a one-line string for displaying +doc about a function etc. appropriate to the context around point. +It should return nil if there's no doc appropriate for the context. +Typically doc is returned if point is on a function-like name or in its +arg list. + +This variable is expected to be made buffer-local by modes (other than +Emacs Lisp mode) that support Eldoc.") + (defun eldoc-print-current-symbol-info () (condition-case err (and (eldoc-display-message-p) - (let* ((current-symbol (eldoc-current-symbol)) - (current-fnsym (eldoc-fnsym-in-current-sexp)) - (doc (cond - ((eq current-symbol current-fnsym) - (or (eldoc-get-fnsym-args-string current-fnsym) - (eldoc-get-var-docstring current-symbol))) - (t - (or (eldoc-get-var-docstring current-symbol) - (eldoc-get-fnsym-args-string current-fnsym)))))) - (eldoc-message doc))) + (if eldoc-print-current-symbol-info-function + (eldoc-message (funcall eldoc-print-current-symbol-info-function)) + (let* ((current-symbol (eldoc-current-symbol)) + (current-fnsym (eldoc-fnsym-in-current-sexp)) + (doc (cond + ((eq current-symbol current-fnsym) + (or (eldoc-get-fnsym-args-string current-fnsym) + (eldoc-get-var-docstring current-symbol))) + (t + (or (eldoc-get-var-docstring current-symbol) + (eldoc-get-fnsym-args-string current-fnsym)))))) + (eldoc-message doc)))) ;; This is run from post-command-hook or some idle timer thing, ;; so we need to be careful that errors aren't ignored. (error (message "eldoc error: %s" err)))) @@ -451,4 +465,5 @@ With prefix ARG, turn ElDoc mode on if and only if ARG is positive." (provide 'eldoc) +;;; arch-tag: c9a58f9d-2055-46c1-9b82-7248b71a8375 ;;; eldoc.el ends here diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 502094fd376..f0f8add4879 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -540,7 +540,8 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (defun elint-check-defcustom-form (form env) "Lint the defcustom FORM in ENV." (if (and (> (length form) 3) - (evenp (length form))) ; even no. of keyword/value args + ;; even no. of keyword/value args ? + (zerop (logand (length form) 1))) (elint-env-add-global-var (elint-form (nth 2 form) env) (car (cdr form))) (elint-error "Malformed variable declaration: %s" form) @@ -801,4 +802,5 @@ 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/elp.el b/lisp/emacs-lisp/elp.el index 01544e3aa14..44400dcaa2c 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -603,4 +603,5 @@ displayed." (provide 'elp) +;;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1 ;;; elp.el ends here diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 7194d4e54d4..a0c2e3c0d70 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -609,4 +609,5 @@ Returns nil if the buffer has been deleted." ;;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2) ;;; End: +;;; arch-tag: d78915b9-9a07-44bf-aac6-04a1fc1bd6d4 ;;; ewoc.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index c4ae7f12b38..5a7cd1093c4 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -403,4 +403,5 @@ Point is saved if FUNCTION is in the current buffer." (provide 'find-func) +;;; arch-tag: 43ecd81c-74dc-4d9a-8f63-a61e55670d64 ;;; find-func.el ends here diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el index a52ae3631fd..1c127295216 100644 --- a/lisp/emacs-lisp/find-gc.el +++ b/lisp/emacs-lisp/find-gc.el @@ -151,4 +151,5 @@ (provide 'find-gc) +;;; arch-tag: 4a26a538-a008-40d9-a1ef-23bb6dbecef4 ;;; find-gc.el ends here diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 4c45112e980..ce5d6124ad7 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -60,4 +60,5 @@ (provide 'lisp-float-type) +;;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d ;;; float-sup.el ends here diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index a176a7ac013..589be6fb771 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -173,4 +173,5 @@ That is a list of elements, each of the form (MAINTAINER PACKAGES...)." (provide 'gulp) +;;; arch-tag: 42750a11-460a-4efc-829f-342d075530e5 ;;; gulp.el ends here diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 0e02f05955f..9d22735e1d0 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -157,4 +157,5 @@ (provide 'helper) +;;; arch-tag: a0984577-d3e9-4124-ae0d-c46fe740f6a9 ;;; helper.el ends here diff --git a/lisp/emacs-lisp/levents.el b/lisp/emacs-lisp/levents.el index 13d13beb998..cd3fe2764c2 100644 --- a/lisp/emacs-lisp/levents.el +++ b/lisp/emacs-lisp/levents.el @@ -290,4 +290,5 @@ GNU Emacs 19 does not currently generate process-output events." (provide 'levents) +;;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525 ;;; levents.el ends here diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 18967677b38..671f3c8ce2a 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,6 +1,6 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2003, 2004 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Maintainer: FSF @@ -180,8 +180,8 @@ Leading comment characters and whitespace should be in regexp group 1." If called with optional MODE and with value `section', return section regexp instead." (if (eq mode 'section) - (concat "^;;;;* " header ":[ \t]*$") - (concat lm-header-prefix header "[ \t]*:[ \t]*"))) + (concat "^;;;;* \\(" header "\\):[ \t]*$") + (concat lm-header-prefix "\\(" header "\\)[ \t]*:[ \t]*"))) (defun lm-get-package-name () "Return package name by looking at the first line." @@ -214,6 +214,7 @@ The end of the section is defined as the beginning of the next section of the same level or lower. The function `lisp-outline-level' is used to compute the level of a section. If no such section exists, return the end of the buffer." + (require 'outline) ;; for outline-regexp. (let ((start (lm-section-start header))) (when start (save-excursion @@ -296,15 +297,16 @@ The returned value is a list of strings, one per line." ;; These give us smart access to the header fields and commentary (defmacro lm-with-file (file &rest body) - "Make a buffer with FILE current, and execute BODY. -If FILE isn't in a buffer, load it in, and kill it after BODY is executed." + "Execute BODY in a buffer containing the contents of FILE. +If FILE is nil, execute BODY in the current buffer." (let ((filesym (make-symbol "file"))) - `(save-excursion - (let ((,filesym ,file)) - (if ,filesym (set-buffer (find-file-noselect ,filesym))) - (prog1 (progn ,@body) - (if (and ,filesym (not (get-buffer-window (current-buffer) t))) - (kill-buffer (current-buffer)))))))) + `(let ((,filesym ,file)) + (if ,filesym + (with-temp-buffer + (insert-file-contents ,filesym) + ,@body) + (save-excursion + ,@body))))) (put 'lm-with-file 'lisp-indent-function 1) (put 'lm-with-file 'edebug-form-spec t) @@ -450,14 +452,14 @@ This can be found in an RCS or SCCS header." (if keywords (split-string keywords ",?[ \t]")))) +(defvar finder-known-keywords) (defun lm-keywords-finder-p (&optional file) "Return non-nil if any keywords in FILE are known to finder." (require 'finder) (let ((keys (lm-keywords-list file))) (catch 'keyword-found (while keys - (if (assoc (intern (car keys)) - (with-no-warnings finder-known-keywords)) + (if (assoc (intern (car keys)) finder-known-keywords) (throw 'keyword-found t)) (setq keys (cdr keys))) nil))) @@ -520,7 +522,7 @@ copyright notice is allowed." (setq ret (cond ((null name) - (format "Package %s does not exist")) + "Can't find package name") ((not (lm-authors)) "`Author:' tag missing") ((not (lm-maintainer)) @@ -544,7 +546,7 @@ copyright notice is allowed." (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$" "\\|^;;;[ \t]+ End of file[ \t]+" name) nil t))) - (format "Can't find the footer line")) + "Can't find the footer line") ((not (and (lm-copyright-mark) (lm-crack-copyright))) "Can't find a valid copyright notice") ((not (or non-fsf-ok @@ -607,4 +609,5 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (provide 'lisp-mnt) +;;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e ;;; lisp-mnt.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index a7dad3428f5..8cd0fdf0da0 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1,6 +1,6 @@ ;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -;; Copyright (C) 1985, 1986, 1999, 2000, 2001, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1985,86,1999,2000,01,03,2004 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages @@ -173,8 +173,6 @@ ;; because lisp-fill-paragraph should do the job. ;; I believe that newcomment's auto-fill code properly deals with it -stef ;;(set (make-local-variable 'adaptive-fill-mode) nil) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'lisp-mode-auto-fill) (make-local-variable 'indent-line-function) (setq indent-line-function 'lisp-indent-line) (make-local-variable 'indent-region-function) @@ -182,7 +180,7 @@ (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (make-local-variable 'outline-regexp) - (setq outline-regexp ";;;;* \\|(") + (setq outline-regexp ";;;;* [^ \t\n]\\|(") (make-local-variable 'outline-level) (setq outline-level 'lisp-outline-level) (make-local-variable 'comment-start) @@ -195,8 +193,8 @@ (setq comment-add 1) ;default to `;;' in comment-region (make-local-variable 'comment-column) (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'lisp-comment-indent) + ;; Don't get confused by `;' in doc strings when paragraph-filling. + (set (make-local-variable 'comment-use-global-state) t) (make-local-variable 'imenu-generic-expression) (setq imenu-generic-expression lisp-imenu-generic-expression) (make-local-variable 'multibyte-syntax-as-symbol) @@ -205,14 +203,14 @@ (setq font-lock-defaults '((lisp-font-lock-keywords lisp-font-lock-keywords-1 lisp-font-lock-keywords-2) - nil nil (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun + nil nil (("+-*/.<>=!?$%_&~^:" . "w")) nil (font-lock-mark-block-function . mark-defun) (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function)))) (defun lisp-outline-level () "Lisp mode `outline-level' function." - (if (looking-at "(") + (if (looking-at "(\\|;;;###autoload") 1000 (looking-at outline-regexp) (- (match-end 0) (match-beginning 0)))) @@ -358,6 +356,9 @@ if that value is non-nil." (set-syntax-table lisp-mode-syntax-table) (run-mode-hooks 'lisp-mode-hook)) +;; Used in old LispM code. +(defalias 'common-lisp-mode 'lisp-mode) + ;; This will do unless inf-lisp.el is loaded. (defun lisp-eval-defun (&optional and-go) "Send the current defun to the Lisp process made by \\[run-lisp]." @@ -448,14 +449,18 @@ alternative printed representations that can be displayed." If CHAR is not a character, return nil." (and (integerp char) (characterp (event-basic-type char)) - (concat - "?" - (mapconcat - (lambda (modif) - (cond ((eq modif 'super) "\\s-") - (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-)))) - (event-modifiers char) "") - (string (event-basic-type char))))) + (let ((c (event-basic-type char))) + (concat + "?" + (mapconcat + (lambda (modif) + (cond ((eq modif 'super) "\\s-") + (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-)))) + (event-modifiers char) "") + (cond + ((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c)) + ((eq c 127) "\\C-?") + (t (string c))))))) (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. @@ -512,27 +517,30 @@ With argument, print output into current buffer." expr 'args))))) expr))))))) - (let ((unabbreviated (let ((print-length nil) (print-level nil)) - (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))) - (setq end (point)) - (when (and (bufferp standard-output) - (or (not (null print-length)) - (not (null print-level))) - (not (string= unabbreviated - (buffer-substring-no-properties beg end)))) - (last-sexp-setup-props beg end value - unabbreviated - (buffer-substring-no-properties beg end)) - )))))) + (eval-last-sexp-print-value value)))) + +(defun eval-last-sexp-print-value (value) + (let ((unabbreviated (let ((print-length nil) (print-level nil)) + (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))) + (setq end (point)) + (when (and (bufferp standard-output) + (or (not (null print-length)) + (not (null print-level))) + (not (string= unabbreviated + (buffer-substring-no-properties beg end)))) + (last-sexp-setup-props beg end value + unabbreviated + (buffer-substring-no-properties beg end)) + )))) (defun eval-last-sexp (eval-last-sexp-arg-internal) @@ -663,8 +671,8 @@ which see." ;; This function just forces a more costly detection of comments (using ;; parse-partial-sexp from beginning-of-defun). I.e. It avoids the problem of ;; taking a `;' inside a string started on another line for a comment starter. -;; Note: `newcomment' gets it right in 99% of the cases if you're using -;; font-lock, anyway, so we could get rid of it. -stef +;; Note: `newcomment' gets it right now since we set comment-use-global-state +;; so we could get rid of it. -stef (defun lisp-mode-auto-fill () (if (> (current-column) (current-fill-column)) (if (save-excursion @@ -1167,4 +1175,5 @@ means don't indent that line." (provide 'lisp-mode) +;;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf ;;; lisp-mode.el ends here diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index c6ec7cf5b9e..e1ed508b865 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -1,6 +1,6 @@ ;;; lisp.el --- Lisp editing commands for Emacs -;; Copyright (C) 1985, 1986, 1994, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1985, 86, 1994, 2000, 2004 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: lisp, languages @@ -157,8 +157,9 @@ normal recipe (see `beginning-of-defun'). Major modes can define this if defining `defun-prompt-regexp' is not sufficient to handle the mode's needs. -The function should go to the line on which the current defun starts, -and return non-nil, or should return nil if it can't find the beginning.") +The function (of no args) should go to the line on which the current +defun starts, and return non-nil, or should return nil if it can't +find the beginning.") (defun beginning-of-defun (&optional arg) "Move backward to the beginning of a defun. @@ -187,7 +188,12 @@ If variable `beginning-of-defun-function' is non-nil, its value is called as a function to find the defun's beginning." (interactive "p") (if beginning-of-defun-function - (funcall beginning-of-defun-function) + (if (> (setq arg (or arg 1)) 0) + (dotimes (i arg) + (funcall beginning-of-defun-function)) + ;; Better not call end-of-defun-function directly, in case + ;; it's not defined. + (end-of-defun (- arg))) (and arg (< arg 0) (not (eobp)) (forward-char 1)) (and (re-search-backward (if defun-prompt-regexp (concat (if open-paren-in-column-0-is-defun-start @@ -217,12 +223,17 @@ 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") + (if (or (null arg) (= arg 0)) (setq arg 1)) (if end-of-defun-function - (funcall end-of-defun-function) - (if (or (null arg) (= arg 0)) (setq arg 1)) + (if (> arg 0) + (dotimes (i arg) + (funcall end-of-defun-function)) + ;; Better not call beginning-of-defun-function + ;; directly, in case it's not defined. + (beginning-of-defun (- arg))) (let ((first t)) (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point)) npos) + (let ((pos (point))) (while (progn (if (and first (progn @@ -266,10 +277,14 @@ 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)) - (end-of-defun) - (push-mark (point) nil t) (beginning-of-defun) + (push-mark (point) nil t) + (end-of-defun) + (exchange-point-and-mark) (re-search-backward "^\n" (- (point) 1) t)))) (defun narrow-to-defun (&optional arg) @@ -279,10 +294,13 @@ Optional ARG is ignored." (interactive) (save-excursion (widen) - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (narrow-to-region (point) end)))) + ;; 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))) + (end-of-defun) + (narrow-to-region beg (point))))) (defun insert-parentheses (arg) "Enclose following ARG sexps in parentheses. Leave point after open-paren. @@ -445,4 +463,5 @@ considered." (display-completion-list list))) (message "Making completion list...%s" "done"))))))) +;;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/lmenu.el b/lisp/emacs-lisp/lmenu.el index b97b3577edb..ab29ed972fc 100644 --- a/lisp/emacs-lisp/lmenu.el +++ b/lisp/emacs-lisp/lmenu.el @@ -436,4 +436,5 @@ BEFORE, if provided, is the name of a menu before which this menu should (provide 'lmenu) +;;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1 ;;; lmenu.el ends here diff --git a/lisp/emacs-lisp/lselect.el b/lisp/emacs-lisp/lselect.el index 693e6474f0a..b292eefbaec 100644 --- a/lisp/emacs-lisp/lselect.el +++ b/lisp/emacs-lisp/lselect.el @@ -232,4 +232,5 @@ the kill ring or the Clipboard." (provide 'lselect) +;;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556 ;;; lselect.el ends here diff --git a/lisp/emacs-lisp/lucid.el b/lisp/emacs-lisp/lucid.el index d039fcea9ca..80e5ef330d3 100644 --- a/lisp/emacs-lisp/lucid.el +++ b/lisp/emacs-lisp/lucid.el @@ -263,4 +263,5 @@ This is an XEmacs compatibility function." (provide 'lucid) +;;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e ;;; lucid.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el new file mode 100644 index 00000000000..b5a279bbbf4 --- /dev/null +++ b/lisp/emacs-lisp/macroexp.el @@ -0,0 +1,197 @@ +;;; macroexp.el --- Additional macro-expansion support +;; +;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. +;; +;; Author: Miles Bader <miles@gnu.org> +;; Keywords: lisp, compiler, macros + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This file contains macro-expansions functions that are not defined in +;; the Lisp core, namely `macroexpand-all', which expands all macros in +;; a form, not just a top-level one. +;; + +;;; Code: + +;; Bound by the top-level `macroexpand-all', and modified to include any +;; macros defined by `defmacro'. +(defvar macroexpand-all-environment nil) + +(defun maybe-cons (car cdr original-cons) + "Return (CAR . CDR), using ORIGINAL-CONS if possible." + (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons))) + original-cons + (cons car cdr))) + +;; We use this special macro to iteratively process forms and share list +;; structure of the result with the input. Doing so recursively using +;; `maybe-cons' results in excessively deep recursion for very long +;; input forms. +(defmacro macroexp-accumulate (#1=#:\(var\ list\) &rest body) + "Return a list of the results of evaluating BODY for each element of LIST. +Evaluate BODY with VAR bound to each `car' from LIST, in turn. +Return a list of the values of the final form in BODY. +The list structure of the result will share as much with LIST as +possible (for instance, when BODY just returns VAR unchanged, the +result will be eq to LIST)." + (let ((var (car #1#)) + (list (cadr #1#)) + (shared (make-symbol "shared")) + (unshared (make-symbol "unshared")) + (tail (make-symbol "tail")) + (new-el (make-symbol "new-el"))) + `(let* ((,shared ,list) + (,unshared nil) + (,tail ,shared) + ,var ,new-el) + (while ,tail + (setq ,var (car ,tail) + ,new-el (progn ,@body)) + (unless (eq ,var ,new-el) + (while (not (eq ,shared ,tail)) + (push (pop ,shared) ,unshared)) + (setq ,shared (cdr ,shared)) + (push ,new-el ,unshared)) + (setq ,tail (cdr ,tail))) + (nconc (nreverse ,unshared) ,shared)))) +(put 'macroexp-accumulate 'lisp-indent-function 1) + +(defun macroexpand-all-forms (forms &optional skip) + "Return FORMS with macros expanded. FORMS is a list of forms. +If SKIP is non-nil, then don't expand that many elements at the start of +FORMS." + (macroexp-accumulate (form forms) + (if (or (null skip) (zerop skip)) + (macroexpand-all-1 form) + (setq skip (1- skip)) + form))) + +(defun macroexpand-all-clauses (clauses &optional skip) + "Return CLAUSES with macros expanded. +CLAUSES is a list of lists of forms; any clause that's not a list is ignored. +If SKIP is non-nil, then don't expand that many elements at the start of +each clause." + (macroexp-accumulate (clause clauses) + (if (listp clause) + (macroexpand-all-forms clause skip) + clause))) + +(defun macroexpand-all-1 (form) + "Expand all macros in FORM. +This is an internal version of `macroexpand-all'. +Assumes the caller has bound `macroexpand-all-environment'." + (if (and (listp form) (eq (car form) 'backquote-list*)) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow input + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexpand-all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexpand form macroexpand-all-environment)) + (if (consp form) + (let ((fun (car form))) + (cond + ((eq fun 'cond) + (maybe-cons fun (macroexpand-all-clauses (cdr form)) form)) + ((eq fun 'condition-case) + (maybe-cons + fun + (maybe-cons (cadr form) + (maybe-cons (macroexpand-all-1 (nth 2 form)) + (macroexpand-all-clauses (nthcdr 3 form) 1) + (cddr form)) + (cdr form)) + form)) + ((eq fun 'defmacro) + (push (cons (cadr form) (cons 'lambda (cddr form))) + macroexpand-all-environment) + (macroexpand-all-forms form 3)) + ((eq fun 'defun) + (macroexpand-all-forms form 3)) + ((memq fun '(defvar defconst)) + (macroexpand-all-forms form 2)) + ((eq fun 'function) + (if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) + (maybe-cons fun + (maybe-cons (macroexpand-all-forms (cadr form) 2) + nil + (cadr form)) + form) + form)) + ((memq fun '(let let*)) + (maybe-cons fun + (maybe-cons (macroexpand-all-clauses (cadr form) 1) + (macroexpand-all-forms (cddr form)) + (cdr form)) + form)) + ((eq fun 'quote) + form) + ((and (consp fun) (eq (car fun) 'lambda)) + ;; embedded lambda + (maybe-cons (macroexpand-all-forms fun 2) + (macroexpand-all-forms (cdr form)) + form)) + ;; The following few cases are for normal function calls that + ;; are known to funcall one of their arguments. The byte + ;; compiler has traditionally handled these functions specially + ;; by treating a lambda expression quoted by `quote' as if it + ;; were quoted by `function'. We make the same transformation + ;; here, so that any code that cares about the difference will + ;; see the same transformation. + ;; First arg is a function: + ((and (memq fun '(apply mapcar mapatoms mapconcat mapc)) + (consp (cadr form)) + (eq (car (cadr form)) 'quote)) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 (cons 'function (cdr (cadr form)))) + (macroexpand-all-forms (cddr form))))) + ;; Second arg is a function: + ((and (eq fun 'sort) + (consp (nth 2 form)) + (eq (car (nth 2 form)) 'quote)) + ;; We don't use `maybe-cons' since there's clearly a change. + (cons fun + (cons (macroexpand-all-1 (cadr form)) + (cons (macroexpand-all-1 + (cons 'function (cdr (nth 2 form)))) + (macroexpand-all-forms (nthcdr 3 form)))))) + (t + ;; For everything else, we just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexpand-all-forms form 1)))) + form))) + +;;;###autoload +(defun macroexpand-all (form &optional environment) + "Return result of expanding macros at all levels in FORM. +If no macros are expanded, FORM is returned unchanged. +The second optional arg ENVIRONMENT specifies an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (let ((macroexpand-all-environment environment)) + (macroexpand-all-1 form))) + +(provide 'macroexp) + +;;; arch-tag: af9b8c24-c196-43bc-91e1-a3570790fa5a +;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 2fa97f163d7..1f493e746fe 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -261,4 +261,5 @@ the current %s and exit." ;; Return the number of actions that were taken. actions)) +;;; arch-tag: 1d0a3201-a151-4c10-b231-4da47c9e6dc3 ;;; map-ynp.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 2e54f224a47..c93868859f0 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,6 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -;; Copyright (C) 1989, 1993, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001, 2004 Free Software Foundation, Inc. ;; Author: Randal Schwartz <merlyn@stonehenge.com> ;; Keywords: lisp @@ -120,12 +120,10 @@ in the variable `values'." (message "%s" (buffer-substring (point-min) (point))) )))))) (with-output-to-temp-buffer "*Pp Eval Output*" - (pp (car values))) - (save-excursion - (set-buffer "*Pp Eval Output*") - (emacs-lisp-mode) - (make-local-variable 'font-lock-verbose) - (setq font-lock-verbose nil)))) + (pp (car values)) + (with-current-buffer standard-output + (emacs-lisp-mode) + (set (make-local-variable 'font-lock-verbose) nil))))) ;;;###autoload (defun pp-eval-last-sexp (arg) @@ -167,4 +165,5 @@ Ignores leading comment characters." (provide 'pp) ; so (require 'pp) works +;;; arch-tag: b0f7c65b-02c7-42bb-9ee3-508a59b8fbb9 ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 8740a68911f..9c904e6c0bc 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -682,4 +682,5 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (provide 're-builder) +;;; arch-tag: 5c5515ac-4085-4524-a421-033f44f032e7 ;;; re-builder.el ends here diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index c85f83e85e3..33aad745828 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -307,4 +307,5 @@ in REGEXP." (provide 'regexp-opt) +;;; arch-tag: 6c5a66f4-29af-4fd6-8c3b-4b554d5b4370 ;;; regexp-opt.el ends here diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index c0cae5b5771..ae9151585fe 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -255,4 +255,5 @@ useful information: (provide 'regi) +;;; arch-tag: 804b4e45-4109-4f76-9a88-21887b881747 ;;; regi.el ends here diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 6891619c20e..fce07953ba9 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -162,4 +162,5 @@ will be performed." (provide 'ring) +;;; arch-tag: e707682b-ed69-47c9-b20f-cf2c68cc92d2 ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 3ac3538822d..6656cf5ed3c 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 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: FSF @@ -120,6 +120,7 @@ (optional . zero-or-one) (minimal-match . (rx-greedy 1 1)) (maximal-match . (rx-greedy 1 1)) + (backref . (rx-backref 1 1 rx-check-backref)) (line-start . "^") (line-end . "$") (string-start . "\\`") @@ -175,7 +176,9 @@ all arguments must satisfy PREDICATE.") (escape . ?\\) (character-quote . ?/) (comment-start . ?<) - (comment-end . ?>)) + (comment-end . ?>) + (string-delimiter . ?|) + (comment-delimiter . ?!)) "Alist mapping Rx syntax symbols to syntax characters. Each entry has the form (SYMBOL . CHAR), where SYMBOL is a valid symbol in `(syntax SYMBOL)', and CHAR is the syntax character @@ -204,6 +207,7 @@ regular expressions.") (japanese-katakana-two-byte . ?K) (korean-hangul-two-byte . ?N) (cyrillic-two-byte . ?Y) + (combining-diacritic . ?^) (ascii . ?a) (arabic . ?b) (chinese . ?c) @@ -255,16 +259,16 @@ See also `rx-constituents'." (type-pred (nth 3 rx))) (when (and (not (null min-args)) (< nargs min-args)) - (error "Rx form `%s' requires at least %d args" + (error "rx form `%s' requires at least %d args" (car form) min-args)) (when (and (not (null max-args)) (> nargs max-args)) - (error "Rx form `%s' accepts at most %d args" + (error "rx form `%s' accepts at most %d args" (car form) max-args)) (when (not (null type-pred)) (dolist (sub-form (cdr form)) (unless (funcall type-pred sub-form) - (error "Rx form `%s' requires args satisfying `%s'" + (error "rx form `%s' requires args satisfying `%s'" (car form) type-pred)))))) @@ -286,9 +290,11 @@ FORM is of the form `(and FORM1 ...)'." (dolist (arg (cdr form)) (unless (stringp arg) (setq all-args-strings nil))) - (if all-args-strings - (regexp-opt (cdr form)) - (mapconcat #'rx-to-string (cdr form) "\\|")))) + (concat "\\(?:" + (if all-args-strings + (regexp-opt (cdr form)) + (mapconcat #'rx-to-string (cdr form) "\\|")) + "\\)"))) (defun rx-quote-for-set (string) @@ -308,10 +314,10 @@ If STRING starts with a '^', move it to the end." "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")) + (error "String arg for rx `any' must not be empty")) ((stringp arg) t) (t - (error "Rx `any' requires string or character arg")))) + (error "rx `any' requires string or character arg")))) (defun rx-any (form) @@ -328,22 +334,23 @@ matches anything." (concat "[" (rx-quote-for-set (cadr form)) "]"))))) -(defun rx-check-not (form) - "Check arguments of FORM. FORM is `(not ...)'." +(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)) + (error "rx `not' syntax error: %s" form)) t) (defun rx-not (form) "Parse and produce code from FORM. FORM is `(not ...)'." (rx-check form) - (let ((result (rx-to-string (cadr form) 'no-group))) + (let ((result (rx-to-string (cadr form) 'no-group)) + case-fold-search) (cond ((string-match "\\`\\[^" result) (if (= (length result) 4) (substring result 2 3) @@ -373,14 +380,14 @@ FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'." (cond ((= (length form) 3) (unless (and (integerp (nth 1 form)) (> (nth 1 form) 0)) - (error "Rx `repeat' requires positive integer first arg")) + (error "rx `repeat' requires positive integer first arg")) (format "%s\\{%d\\}" (rx-to-string (nth 2 form)) (nth 1 form))) ((or (not (integerp (nth 2 form))) (< (nth 2 form) 0) (not (integerp (nth 1 form))) (< (nth 1 form) 0) (< (nth 2 form) (nth 1 form))) - (error "Rx `repeat' range error")) + (error "rx `repeat' range error")) (t (format "%s\\{%d,%d\\}" (rx-to-string (nth 3 form)) (nth 1 form) (nth 2 form))))) @@ -393,6 +400,16 @@ FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'." (cdr form) nil) "\\)")) +(defun rx-backref (form) + "Parse and produce code from FORM, which is `(backref N)'." + (rx-check form) + (format "\\%d" (nth 1 form))) + +(defun rx-check-backref (arg) + "Check arg ARG for Rx `backref'." + (or (and (integerp arg) (>= arg 1) (<= arg 9)) + (error "rx `backref' requires numeric 1<=arg<=9: %s" arg))) + (defun rx-kleene (form) "Parse and produce code from FORM. FORM is `(OP FORM1)', where OP is one of the `zero-or-one', @@ -481,10 +498,10 @@ of all atomic regexps." (defun rx-greedy (form) - "Parse and produce code from FORM. If FORM is '(minimal-match -FORM1)', non-greedy versions of `*', `+', and `?' operators will be -used in FORM1. If FORM is '(maximal-match FORM1)', greedy operators -will be used." + "Parse and produce code from FORM. +If FORM is '(minimal-match FORM1)', non-greedy versions of `*', +`+', and `?' operators will be used in FORM1. If FORM is +'(maximal-match FORM1)', greedy operators will be used." (rx-check form) (let ((rx-greedy-flag (eq (car form) 'maximal-match))) (rx-to-string (cadr form)))) @@ -510,19 +527,19 @@ NO-GROUP non-nil means don't put shy groups around the result." (cond ((stringp info) info) ((null info) - (error "Unknown Rx form `%s'" form)) + (error "Unknown rx form `%s'" form)) (t (funcall (nth 0 info) form))))) ((consp form) (let ((info (rx-info (car form)))) (unless (consp info) - (error "Unknown Rx form `%s'" (car form))) + (error "Unknown rx form `%s'" (car form))) (let ((result (funcall (nth 0 info) form))) (if (or no-group (string-match "\\`\\\\[(]" result)) result (concat "\\(?:" result "\\)"))))) (t - (error "Rx syntax error at `%s'" form)))) + (error "rx syntax error at `%s'" form)))) ;;;###autoload @@ -663,6 +680,8 @@ CHAR `character-quote' (\\s/) `comment-start' (\\s<) `comment-end' (\\s>) + `string-delimiter' (\\s|) + `comment-delimiter' (\\s!) `(not (syntax SYNTAX))' matches a character that has not syntax SYNTAX. @@ -691,6 +710,7 @@ CHAR `japanese-katakana-two-byte' (\\cK) `korean-hangul-two-byte' (\\cN) `cyrillic-two-byte' (\\cY) + `combining-diacritic' (\\c^) `ascii' (\\ca) `arabic' (\\cb) `chinese' (\\cc) @@ -730,7 +750,7 @@ CHAR `(minimal-match SEXP)' produce a non-greedy regexp for SEXP. Normally, regexps matching - zero or more occurrances of something are \"greedy\" in that they + zero or more occurrences of something are \"greedy\" in that they match as much as they can, as long as the overall regexp can still match. A non-greedy regexp matches as little as possible. @@ -779,16 +799,22 @@ CHAR `(repeat N M SEXP)' matches N to M occurrences of what SEXP matches. +`(backref N)' + matches what was matched previously by submatch N. + +`(backref N)' + matches what was matched previously by submatch N. + `(eval FORM)' - evaluate FORM and insert result. If result is a string, - `regexp-quote' it. + evaluate FORM and insert result. If result is a string, + `regexp-quote' it. `(regexp REGEXP)' - include REGEXP in string notation in the result." - - `(rx-to-string ',regexp)) + include REGEXP in string notation in the result." + (rx-to-string regexp)) (provide 'rx) +;;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b ;;; rx.el ends here diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 82230b1d2ec..eeaaa7ffc0a 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -161,7 +161,7 @@ See the documentation for `list-load-path-shadows' for further information." ;; sizes. (and (= (nth 7 (file-attributes f1)) (nth 7 (file-attributes f2))) - (zerop (call-process "cmp" nil nil nil "-s" f1 f2)))))))) + (eq 0 (call-process "cmp" nil nil nil "-s" f1 f2)))))))) ;;;###autoload (defun list-load-path-shadows () @@ -257,4 +257,5 @@ version unless you know what you are doing.\n") (provide 'shadow) +;;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830 ;;; shadow.el ends here diff --git a/lisp/emacs-lisp/sregex.el b/lisp/emacs-lisp/sregex.el index 1200e7b3c30..3f7aaa16bce 100644 --- a/lisp/emacs-lisp/sregex.el +++ b/lisp/emacs-lisp/sregex.el @@ -605,4 +605,5 @@ has one of the following forms: (provide 'sregex) +;;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492 ;;; sregex.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 7bd8378ab86..793306adda5 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -289,4 +289,6 @@ Point is at POS when this function returns." ;; (syntax-ppss-depth (syntax-ppss)))) (provide 'syntax) + +;;; arch-tag: 302f1eeb-e77c-4680-a8c5-c543e01161a5 ;;; syntax.el ends here diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el new file mode 100644 index 00000000000..48ec9fa64da --- /dev/null +++ b/lisp/emacs-lisp/tcover-ses.el @@ -0,0 +1,712 @@ +;;;; testcover-ses.el -- Example use of `testcover' to test "SES" + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Jonathan Yavner <jyavner@engineer.com> +;; Maintainer: Jonathan Yavner <jyavner@engineer.com> +;; Keywords: spreadsheet lisp utility + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(require 'testcover) + +;;;Here are some macros that exercise SES. Set `pause' to t if you want the +;;;macros to pause after each step. +(let* ((pause nil) + (x (if pause "q" "")) + (y "ses-test.ses\r<")) + ;;Fiddle with the existing spreadsheet + (fset 'ses-exercise-example + (concat "" data-directory "ses-example.ses\r<" + x "10" + x "" + x "" + x "pses-center\r" + x "p\r" + x "\t\t" + x "\r A9 B9\r" + x "" + x "\r2\r" + x "" + x "50\r" + x "4" + x "" + x "" + x "(+ o\0" + x "-1o \r" + x "" + x)) + ;;Create a new spreadsheet + (fset 'ses-exercise-new + (concat y + x "\"%.8g\"\r" + x "2\r" + x "" + x "" + x "2" + x "\"Header\r" + x "(sqrt 1\r" + x "pses-center\r" + x "\t" + x "(+ A2 A3\r" + x "(* B2 A3\r" + x "2" + x "\rB3\r" + x "" + x)) + ;;Basic cell display + (fset 'ses-exercise-display + (concat y ":(revert-buffer t t)\r" + x "" + x "\"Very long\r" + x "w3\r" + x "w3\r" + x "(/ 1 0\r" + x "234567\r" + x "5w" + x "\t1\r" + x "" + x "234567\r" + x "\t" + x "" + x "345678\r" + x "3w" + x "\0>" + x "" + x "" + x "" + x "" + x "" + x "" + x "" + x "1\r" + x "" + x "" + x "\"1234567-1234567-1234567\r" + x "123\r" + x "2" + x "\"1234567-1234567-1234567\r" + x "123\r" + x "w8\r" + x "\"1234567\r" + x "w5\r" + x)) + ;;Cell formulas + (fset 'ses-exercise-formulas + (concat y ":(revert-buffer t t)\r" + x "\t\t" + x "\t" + x "(* B1 B2 D1\r" + x "(* B2 B3\r" + x "(apply '+ (ses-range B1 B3)\r" + x "(apply 'ses+ (ses-range B1 B3)\r" + x "(apply 'ses+ (ses-range A2 A3)\r" + x "(mapconcat'number-to-string(ses-range B2 B4) \"-\"\r" + x "(apply 'concat (reverse (ses-range A3 D3))\r" + x "(* (+ A2 A3) (ses+ B2 B3)\r" + x "" + x "2" + x "5\t" + x "(apply 'ses+ (ses-range E1 E2)\r" + x "(apply 'ses+ (ses-range A5 B5)\r" + x "(apply 'ses+ (ses-range E1 F1)\r" + x "(apply 'ses+ (ses-range D1 E1)\r" + x "\t" + x "(ses-average (ses-range A2 A5)\r" + x "(apply 'ses+ (ses-range A5 A6)\r" + x "k" + x "" + x "" + x "2" + x "3" + x "o" + x "2o" + x "3k" + x "(ses-average (ses-range B3 E3)\r" + x "k" + x "12345678\r" + x)) + ;;Recalculating and reconstructing + (fset 'ses-exercise-recalc + (concat y ":(revert-buffer t t)\r" + x "" + x "\t\t" + x "" + x "(/ 1 0\r" + x "" + x "\n" + x "" + x "\"%.6g\"\r" + x "" + x ">nw" + x "\0>xdelete-region\r" + x "" + x "8" + x "\0>xdelete-region\r" + x "" + x "" + x "k" + x "" + x "\"Very long\r" + x "" + x "\r\r" + x "" + x "o" + x "" + x "\"Very long2\r" + x "o" + x "" + x "\rC3\r" + x "\rC2\r" + x "\0" + x "\rC4\r" + x "\rC2\r" + x "\0" + x "" + x "xses-mode\r" + x "<" + x "2k" + x)) + ;;Header line + (fset 'ses-exercise-header-row + (concat y ":(revert-buffer t t)\r" + x "<" + x ">" + x "6<" + x ">" + x "7<" + x ">" + x "8<" + x "2<" + x ">" + x "3w" + x "10<" + x ">" + x "2" + x)) + ;;Detecting unsafe formulas and printers + (fset 'ses-exercise-unsafe + (concat y ":(revert-buffer t t)\r" + x "p(lambda (x) (delete-file x))\rn" + x "p(lambda (x) (delete-file \"ses-nothing\"))\ry" + x "\0n" + x "(delete-file \"x\"\rn" + x "(delete-file \"ses-nothing\"\ry" + x "\0n" + x "(open-network-stream \"x\" nil \"localhost\" \"smtp\"\ry" + x "\0n" + x)) + ;;Inserting and deleting rows + (fset 'ses-exercise-rows + (concat y ":(revert-buffer t t)\r" + x "" + x "\"%s=\"\r" + x "20" + x "p\"%s+\"\r" + x "" + x "123456789\r" + x "\021" + x "" + x "" + x "(not B25\r" + x "k" + x "jA3\r" + x "19" + x "" + x "100" ;Make this approx your CPU speed in MHz + x)) + ;;Inserting and deleting columns + (fset 'ses-exercise-columns + (concat y ":(revert-buffer t t)\r" + x "\"%s@\"\r" + x "o" + x "" + x "o" + x "" + x "k" + x "w8\r" + x "p\"%.7s*\"\r" + x "o" + x "" + x "2o" + x "3k" + x "\"%.6g\"\r" + x "26o" + x "\026\t" + x "26o" + x "0\r" + x "26\t" + x "400" + x "50k" + x "\0D" + x)) + (fset 'ses-exercise-editing + (concat y ":(revert-buffer t t)\r" + x "1\r" + x "('x\r" + x "" + x "" + x "\r\r" + x "w9\r" + x "\r.5\r" + x "\r 10\r" + x "w12\r" + x "\r'\r" + x "\r\r" + x "jA4\r" + x "(+ A2 100\r" + x "3\r" + x "jB1\r" + x "(not A1\r" + x "\"Very long\r" + x "" + x "h" + x "H" + x "" + x ">\t" + x "" + x "" + x "2" + x "" + x "o" + x "h" + x "\0" + x "\"Also very long\r" + x "H" + x "\0'\r" + x "'Trial\r" + x "'qwerty\r" + x "(concat o<\0" + x "-1o\r" + x "(apply '+ o<\0-1o\r" + x "2" + x "-2" + x "-2" + x "2" + x "" + x "H" + x "\0" + x "\"Another long one\r" + x "H" + x "" + x "<" + x "" + x ">" + x "\0" + x)) + ;;Sorting of columns + (fset 'ses-exercise-sort-column + (concat y ":(revert-buffer t t)\r" + x "\"Very long\r" + x "99\r" + x "o13\r" + x "(+ A3 B3\r" + x "7\r8\r(* A4 B4\r" + x "\0A\r" + x "\0B\r" + x "\0C\r" + x "o" + x "\0C\r" + x)) + ;;Simple cell printers + (fset 'ses-exercise-cell-printers + (concat y ":(revert-buffer t t)\r" + x "\"4\t76\r" + x "\"4\n7\r" + x "p\"{%S}\"\r" + x "p(\"[%s]\")\r" + x "p(\"<%s>\")\r" + x "\0" + x "p\r" + x "pnil\r" + x "pses-dashfill\r" + x "48\r" + x "\t" + x "\0p\r" + x "p\r" + x "pses-dashfill\r" + x "\0pnil\r" + x "5\r" + x "pses-center\r" + x "\"%s\"\r" + x "w8\r" + x "p\r" + x "p\"%.7g@\"\r" + x "\r" + x "\"%.6g#\"\r" + x "\"%.6g.\"\r" + x "\"%.6g.\"\r" + x "pidentity\r" + x "6\r" + x "\"UPCASE\r" + x "pdowncase\r" + x "(* 3 4\r" + x "p(lambda (x) '(\"Hi\"))\r" + x "p(lambda (x) '(\"Bye\"))\r" + x)) + ;;Spanning cell printers + (fset 'ses-exercise-spanning-printers + (concat y ":(revert-buffer t t)\r" + x "p\"%.6g*\"\r" + x "pses-dashfill-span\r" + x "5\r" + x "pses-tildefill-span\r" + x "\"4\r" + x "p\"$%s\"\r" + x "p(\"$%s\")\r" + x "8\r" + x "p(\"!%s!\")\r" + x "\t\"12345678\r" + x "pses-dashfill-span\r" + x "\"23456789\r" + x "\t" + x "(not t\r" + x "w6\r" + x "\"5\r" + x "o" + x "k" + x "k" + x "\t" + x "" + x "o" + x "2k" + x "k" + x)) + ;;Cut/copy/paste - within same buffer + (fset 'ses-exercise-paste-1buf + (concat y ":(revert-buffer t t)\r" + x "\0w" + x "" + x "o" + x "\"middle\r" + x "\0" + x "w" + x "\0" + x "w" + x "" + x "" + x "2y" + x "y" + x "y" + x ">" + x "y" + x ">y" + x "<" + x "p\"<%s>\"\r" + x "pses-dashfill\r" + x "\0" + x "" + x "" + x "y" + x "\r\0w" + x "\r" + x "3(+ G2 H1\r" + x "\0w" + x ">" + x "" + x "8(ses-average (ses-range G2 H2)\r" + x "\0k" + x "7" + x "" + x "(ses-average (ses-range E7 E9)\r" + x "\0" + x "" + x "(ses-average (ses-range E7 F7)\r" + x "\0k" + x "" + x "(ses-average (ses-range D6 E6)\r" + x "\0k" + x "" + x "2" + x "\"Line A\r" + x "pses-tildefill-span\r" + x "\"Subline A(1)\r" + x "pses-dashfill-span\r" + x "\0w" + x "" + x "" + x "\0w" + x "" + x)) + ;;Cut/copy/paste - between two buffers + (fset 'ses-exercise-paste-2buf + (concat y ":(revert-buffer t t)\r" + x "o\"middle\r\0" + x "" + x "4bses-test.txt\r" + x " " + x "\"xxx\0" + x "wo" + x "" + x "" + x "o\"\0" + x "wo" + x "o123.45\0" + x "o" + x "o1 \0" + x "o" + x ">y" + x "o symb\0" + x "oy2y" + x "o1\t\0" + x "o" + x "w9\np\"<%s>\"\n" + x "o\n2\t\"3\nxxx\t5\n\0" + x "oy" + x)) + ;;Export text, import it back + (fset 'ses-exercise-import-export + (concat y ":(revert-buffer t t)\r" + x "\0xt" + x "4bses-test.txt\r" + x "\n-1o" + x "xTo-1o" + x "'crunch\r" + x "pses-center-span\r" + x "\0xT" + x "o\n-1o" + x "\0y" + x "\0xt" + x "\0y" + x "12345678\r" + x "'bunch\r" + x "\0xtxT" + x))) + +(defun ses-exercise-macros () + "Executes all SES coverage-test macros." + (dolist (x '(ses-exercise-example + ses-exercise-new + ses-exercise-display + ses-exercise-formulas + ses-exercise-recalc + ses-exercise-header-row + ses-exercise-unsafe + ses-exercise-rows + ses-exercise-columns + ses-exercise-editing + ses-exercise-sort-column + ses-exercise-cell-printers + ses-exercise-spanning-printers + ses-exercise-paste-1buf + ses-exercise-paste-2buf + ses-exercise-import-export)) + (message "<Testing %s>" x) + (execute-kbd-macro x))) + +(defun ses-exercise-signals () + "Exercise code paths that lead to error signals, other than those for +spreadsheet files with invalid formatting." + (message "<Checking for expected errors>") + (switch-to-buffer "ses-test.ses") + (deactivate-mark) + (ses-jump 'A1) + (ses-set-curcell) + (dolist (x '((ses-column-widths 14) + (ses-column-printers "%s") + (ses-column-printers ["%s" "%s" "%s"]) ;Should be two + (ses-column-widths [14]) + (ses-delete-column -99) + (ses-delete-column 2) + (ses-delete-row -1) + (ses-goto-data 'hogwash) + (ses-header-row -56) + (ses-header-row 99) + (ses-insert-column -14) + (ses-insert-row 0) + (ses-jump 'B8) ;Covered by preceding cell + (ses-printer-validate '("%s" t)) + (ses-printer-validate '([47])) + (ses-read-header-row -1) + (ses-read-header-row 32767) + (ses-relocate-all 0 0 -1 1) + (ses-relocate-all 0 0 1 -1) + (ses-select (ses-range A1 A2) 'x (ses-range B1 B1)) + (ses-set-cell 0 0 'hogwash nil) + (ses-set-column-width 0 0) + (ses-yank-cells #("a\nb" + 0 1 (ses (A1 nil nil)) + 2 3 (ses (A3 nil nil))) + nil) + (ses-yank-cells #("ab" + 0 1 (ses (A1 nil nil)) + 1 2 (ses (A2 nil nil))) + nil) + (ses-yank-pop nil) + (ses-yank-tsf "1\t2\n3" nil) + (let ((curcell nil)) (ses-check-curcell)) + (let ((curcell 'A1)) (ses-check-curcell 'needrange)) + (let ((curcell '(A1 . A2))) (ses-check-curcell 'end)) + (let ((curcell '(A1 . A2))) (ses-sort-column "B")) + (let ((curcell '(C1 . D2))) (ses-sort-column "B")) + (execute-kbd-macro "jB10\n2") + (execute-kbd-macro [?j ?B ?9 ?\n ?\C-@ ?\C-f ?\C-f cut]) + (progn (kill-new "x") (execute-kbd-macro ">n")) + (execute-kbd-macro "\0w"))) + (condition-case nil + (progn + (eval x) + (signal 'singularity-error nil)) ;Shouldn't get here + (singularity-error (error "No error from %s?" x)) + (error nil))) + ;;Test quit-handling in ses-update-cells. Cant' use `eval' here. + (let ((inhibit-quit t)) + (setq quit-flag t) + (condition-case nil + (progn + (ses-update-cells '(A1)) + (signal 'singularity-error nil)) + (singularity-error (error "Quit failure in ses-update-cells")) + (error nil)) + (setq quit-flag nil))) + +(defun ses-exercise-invalid-spreadsheets () + "Execute code paths that detect invalid spreadsheet files." + ;;Detect invalid spreadsheets + (let ((p&d "\n\n\n(ses-cell A1 nil nil nil nil)\n\n") + (cw "(ses-column-widths [7])\n") + (cp "(ses-column-printers [ses-center])\n") + (dp "(ses-default-printer \"%.7g\")\n") + (hr "(ses-header-row 0)\n") + (p11 "(2 1 1)") + (igp ses-initial-global-parameters)) + (dolist (x (list "(1)" + "(x 2 3)" + "(1 x 3)" + "(1 -1 0)" + "(1 2 x)" + "(1 2 -1)" + "(3 1 1)" + "\n\n(2 1 1)" + "\n\n\n(ses-cell)(2 1 1)" + "\n\n\n(x)\n(2 1 1)" + "\n\n\n\n(ses-cell A2)\n(2 2 2)" + "\n\n\n\n(ses-cell B1)\n(2 2 2)" + "\n\n\n(ses-cell A1 nil nil nil nil)\n(2 1 1)" + (concat p&d "(x)\n(x)\n(x)\n(x)\n" p11) + (concat p&d "(ses-column-widths)(x)\n(x)\n(x)\n" p11) + (concat p&d cw "(x)\n(x)\n(x)\n(2 1 1)") + (concat p&d cw "(ses-column-printers)(x)\n(x)\n" p11) + (concat p&d cw cp "(x)\n(x)\n" p11) + (concat p&d cw cp "(ses-default-printer)(x)\n" p11) + (concat p&d cw cp dp "(x)\n" p11) + (concat p&d cw cp dp "(ses-header-row)" p11) + (concat p&d cw cp dp hr p11) + (concat p&d cw cp dp "\n" hr igp))) + (condition-case nil + (with-temp-buffer + (insert x) + (ses-load) + (signal 'singularity-error nil)) ;Shouldn't get here + (singularity-error (error "%S is an invalid spreadsheet!" x)) + (error nil))))) + +(defun ses-exercise-startup () + "Prepare for coverage tests" + ;;Clean up from any previous runs + (condition-case nil (kill-buffer "ses-example.ses") (error nil)) + (condition-case nil (kill-buffer "ses-test.ses") (error nil)) + (condition-case nil (delete-file "ses-test.ses") (file-error nil)) + (delete-other-windows) ;Needed for "\C-xo" in ses-exercise-editing + (setq ses-mode-map nil) ;Force rebuild + (testcover-unmark-all "ses.el") + ;;Enable + (let ((testcover-1value-functions + ;;forward-line always returns 0, for us. + ;;remove-text-properties always returns t for us. + ;;ses-recalculate-cell returns the same " " any time curcell is a cons + ;;Macros ses-dorange and ses-dotimes-msg generate code that always + ;; returns nil + (append '(forward-line remove-text-properties ses-recalculate-cell + ses-dorange ses-dotimes-msg) + testcover-1value-functions)) + (testcover-constants + ;;These maps get initialized, then never changed again + (append '(ses-mode-map ses-mode-print-map ses-mode-edit-map) + testcover-constants))) + (testcover-start "ses.el" t)) + (require 'unsafep)) ;In case user has safe-functions = t! + + +;;;######################################################################### +(defun ses-exercise () + "Executes all SES coverage tests and displays the results." + (interactive) + (ses-exercise-startup) + ;;Run the keyboard-macro tests + (let ((safe-functions nil) + (ses-initial-size '(1 . 1)) + (ses-initial-column-width 7) + (ses-initial-default-printer "%.7g") + (ses-after-entry-functions '(forward-char)) + (ses-mode-hook nil)) + (ses-exercise-macros) + (ses-exercise-signals) + (ses-exercise-invalid-spreadsheets) + ;;Upgrade of old-style spreadsheet + (with-temp-buffer + (insert " \n\n\n(ses-cell A1 nil nil nil nil)\n\n(ses-column-widths [7])\n(ses-column-printers [nil])\n(ses-default-printer \"%.7g\")\n\n( ;Global parameters (these are read first)\n 1 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n") + (ses-load)) + ;;ses-vector-delete is always called from buffer-undo-list with the same + ;;symbol as argument. We'll give it a different one here. + (let ((x [1 2 3])) + (ses-vector-delete 'x 0 0)) + ;;ses-create-header-string behaves differently in a non-window environment + ;;but we always test under windows. + (let ((window-system (not window-system))) + (scroll-left 7) + (ses-create-header-string)) + ;;Test for nonstandard after-entry functions + (let ((ses-after-entry-functions '(forward-line)) + ses-mode-hook) + (ses-read-cell 0 0 1) + (ses-read-symbol 0 0 t))) + ;;Tests with unsafep disabled + (let ((safe-functions t) + ses-mode-hook) + (message "<Checking safe-functions = t>") + (kill-buffer "ses-example.ses") + (find-file "ses-example.ses")) + ;;Checks for nonstandard default values for new spreadsheets + (let (ses-mode-hook) + (dolist (x '(("%.6g" 8 (2 . 2)) + ("%.8g" 6 (3 . 3)))) + (let ((ses-initial-size (nth 2 x)) + (ses-initial-column-width (nth 1 x)) + (ses-initial-default-printer (nth 0 x))) + (with-temp-buffer + (set-buffer-modified-p t) + (ses-mode))))) + ;;Test error-handling in command hook, outside a macro. + ;;This will ring the bell. + (let (curcell-overlay) + (ses-command-hook)) + ;;Due to use of run-with-timer, ses-command-hook sometimes gets called + ;;after we switch to another buffer. + (switch-to-buffer "*scratch*") + (ses-command-hook) + ;;Print results + (message "<Marking source code>") + (testcover-mark-all "ses.el") + (testcover-next-mark) + ;;Cleanup + (delete-other-windows) + (kill-buffer "ses-test.txt") + ;;Could do this here: (testcover-end "ses.el") + (message "Done")) + +;;; arch-tag: 87052ba4-5cf8-46cf-9375-fe245f3360b8 +;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el new file mode 100644 index 00000000000..4359209b4d4 --- /dev/null +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -0,0 +1,140 @@ +;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Jonathan Yavner <jyavner@engineer.com> +;; Maintainer: Jonathan Yavner <jyavner@engineer.com> +;; Keywords: safety lisp utility + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(require 'testcover) + +;;;These forms are all considered safe +(defconst testcover-unsafep-safe + '(((lambda (x) (* x 2)) 14) + (apply 'cdr (mapcar '(lambda (x) (car x)) y)) + (cond ((= x 4) 5) (t 27)) + (condition-case x (car y) (error (car x))) + (dolist (x y) (message "here: %s" x)) + (dotimes (x 14 (* x 2)) (message "here: %d" x)) + (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) + (let (x) (apply '(lambda (x) (* x 2)) 14)) + (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) + (let ((x 1) (y 2)) (setq x (+ x y))) + (let ((x 1)) (let ((y (+ x 3))) (* x y))) + (let* nil (current-time)) + (let* ((x 1) (y (+ x 3))) (* x y)) + (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) + (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") + (setq buffer-display-count 14 mark-active t) + ;;This is not safe if you insert it into a buffer! + (propertize "x" 'display '(height (progn (delete-file "x") 1)))) + "List of forms that `unsafep' should decide are safe.") + +;;;These forms are considered unsafe +(defconst testcover-unsafep-unsafe + '(( (add-to-list x y) + . (unquoted x)) + ( (add-to-list y x) + . (unquoted y)) + ( (add-to-list 'y x) + . (global-variable y)) + ( (not (delete-file "unsafep.el")) + . (function delete-file)) + ( (cond (t (aset local-abbrev-table 0 0))) + . (function aset)) + ( (cond (t (setq unsafep-vars ""))) + . (risky-local-variable unsafep-vars)) + ( (condition-case format-alist 1) + . (risky-local-variable format-alist)) + ( (condition-case x 1 (error (setq format-alist ""))) + . (risky-local-variable format-alist)) + ( (dolist (x (sort globalvar 'car)) (princ x)) + . (function sort)) + ( (dotimes (x 14) (delete-file "x")) + . (function delete-file)) + ( (let ((post-command-hook "/tmp/")) 1) + . (risky-local-variable post-command-hook)) + ( (let ((x (delete-file "x"))) 2) + . (function delete-file)) + ( (let (x) (add-to-list 'x (delete-file "x"))) + . (function delete-file)) + ( (let (x) (condition-case y (setq x 1 z 2))) + . (global-variable z)) + ( (let (x) (condition-case z 1 (error (delete-file "x")))) + . (function delete-file)) + ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) + . (function setcar)) + ( (let (y) (push (delete-file "x") y)) + . (function delete-file)) + ( (let* ((x 1)) (setq y 14)) + . (global-variable y)) + ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) + . (function kill-buffer)) + ( (mapcar x y) + . (unquoted x)) + ( (mapcar '(lambda (x) (rename-file x "x")) '("unsafep.el")) + . (function rename-file)) + ( (mapconcat x1 x2 " ") + . (unquoted x1)) + ( (pop format-alist) + . (risky-local-variable format-alist)) + ( (push 1 format-alist) + . (risky-local-variable format-alist)) + ( (setq buffer-display-count (delete-file "x")) + . (function delete-file)) + ;;These are actualy safe (they signal errors) + ( (apply '(x) '(1 2 3)) + . (function (x))) + ( (let (((x))) 1) + . (variable (x))) + ( (let (1) 2) + . (variable 1)) + ) + "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") + + +;;;######################################################################### +(defun testcover-unsafep () + "Executes all unsafep tests and displays the coverage results." + (interactive) + (testcover-unmark-all "unsafep.el") + (testcover-start "unsafep.el") + (let (save-functions) + (dolist (x testcover-unsafep-safe) + (if (unsafep x) + (error "%S should be safe" x))) + (dolist (x testcover-unsafep-unsafe) + (if (not (equal (unsafep (car x)) (cdr x))) + (error "%S should be unsafe: %s" (car x) (cdr x)))) + (setq safe-functions t) + (if (or (unsafep '(delete-file "x")) + (unsafep-function 'delete-file)) + (error "safe-functions=t should allow delete-file")) + (setq safe-functions '(setcar)) + (if (unsafep '(setcar x 1)) + (error "safe-functions=(setcar) should allow setcar")) + (if (not (unsafep '(setcdr x 1))) + (error "safe-functions=(setcar) should not allow setcdr"))) + (testcover-mark-all "unsafep.el") + (testcover-end "unsafep.el") + (message "Done")) + +;;; arch-tag: a7616c27-1998-47ae-9304-76d1439dbf29 +;; testcover-unsafep.el ends here. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index d422a42374b..547e2cbd32d 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -171,14 +171,13 @@ call to one of the `testcover-1value-functions'." ;;; Add instrumentation to your module ;;;========================================================================= -;;;###autoload (defun testcover-start (filename &optional byte-compile) "Uses edebug to instrument all macros and functions in FILENAME, then changes the instrumentation from edebug to testcover--much faster, no problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is non-nil, byte-compiles each function after instrumenting." (interactive "f") - (let ((buf (find-file filename)) + (let ((buf (find-file filename)) (load-read-function 'testcover-read) (edebug-all-defs t)) (setq edebug-form-data nil @@ -210,7 +209,8 @@ non-nil, byte-compiles each function after instrumenting." "Reinstruments FORM to use testcover instead of edebug. This function modifies the list that FORM points to. Result is non-nil if FORM will always return the same value." - (let ((fun (car-safe form))) + (let ((fun (car-safe form)) + id) (cond ((not fun) ;Atom (or (not (symbolp form)) @@ -234,10 +234,10 @@ always return the same value." (testcover-reinstrument (cadr form))) ((memq fun testcover-compose-functions) ;;1-valued if all arguments are - (setq fun t) - (mapc #'(lambda (x) (setq fun (or (testcover-reinstrument x) fun))) + (setq id t) + (mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id))) (cdr form)) - fun) + id) ((eq fun 'edebug-enter) ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) @@ -250,17 +250,22 @@ always return the same value." ;; => (testcover-after YYY FORM), mark XXX as ok-coverage (unless (eq (cadr form) 0) (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) - (setq fun (nth 2 form)) + (setq id (nth 2 form)) (setcdr form (nthcdr 2 form)) - (if (not (memq (car-safe (nth 2 form)) testcover-noreturn-functions)) - (setcar form 'testcover-after) + (cond + ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) ;;This function won't return, so set the value in advance ;;(edebug-after (edebug-before XXX) YYY FORM) ;; => (progn (edebug-after YYY nil) FORM) (setcar form 'progn) - (setcar (cdr form) `(testcover-after ,fun nil))) + (setcar (cdr form) `(testcover-after ,id nil))) + ((eq (car-safe (nth 2 form)) '1value) + ;;This function is always supposed to return the same value + (setcar form 'testcover-1value)) + (t + (setcar form 'testcover-after))) (when (testcover-reinstrument (nth 2 form)) - (aset testcover-vector fun '1value))) + (aset testcover-vector id '1value))) ((eq fun 'defun) (if (testcover-reinstrument-list (nthcdr 3 form)) (push (cadr form) testcover-module-1value-functions))) @@ -316,8 +321,11 @@ always return the same value." ;;Hack - pretend the arg is 1-valued here (if (symbolp (cadr form)) ;A pseudoconstant variable t + (if (eq (car (cadr form)) 'edebug-after) + (setq id (car (nth 3 (cadr form)))) + (setq id (car (cadr form)))) (let ((testcover-1value-functions - (cons (car (cadr form)) testcover-1value-functions))) + (cons id testcover-1value-functions))) (testcover-reinstrument (cadr form))))) (t ;Some other function or weird thing (testcover-reinstrument-list (cdr form)) @@ -334,8 +342,8 @@ always be nil, so we return t for 1-valued." result)) (defun testcover-reinstrument-clauses (clauselist) - "Reinstruments each list in CLAUSELIST. Result is t if every -clause is 1-valued." + "Reinstrument each list in CLAUSELIST. +Result is t if every clause is 1-valued." (let ((result t)) (mapc #'(lambda (x) (setq result (and (testcover-reinstrument-list x) result))) @@ -348,15 +356,6 @@ clause is 1-valued." (let ((buf (find-file-noselect buffer))) (eval-buffer buf t))) -(defmacro 1value (form) - "For code-coverage testing, indicate that FORM is expected to always have -the same value." - form) - -(defmacro noreturn (form) - "For code-coverage testing, indicate that FORM will always signal an error." - form) - ;;;========================================================================= ;;; Accumulate coverage data @@ -379,6 +378,19 @@ binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM (aset testcover-vector idx 'ok-coverage))) val) +(defun testcover-1value (idx val) + "Internal function for coverage testing. Returns VAL after installing it in +`testcover-vector' at offset IDX. Error if FORM does not always return the +same value during coverage testing." + (cond + ((eq (aref testcover-vector idx) '1value) + (aset testcover-vector idx (cons '1value val))) + ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) + (equal (cdr (aref testcover-vector idx)) val))) + (error "Value of form marked with `1value' does vary."))) + val) + + ;;;========================================================================= ;;; Display the coverage data as color splotches on your code. @@ -411,6 +423,7 @@ eliminated by adding more test cases." (setq len (1- len) data (aref coverage len)) (when (and (not (eq data 'ok-coverage)) + (not (eq (car-safe data) '1value)) (setq j (+ def-mark (aref points len)))) (setq ov (make-overlay (1- j) j)) (overlay-put ov 'face @@ -445,4 +458,5 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) +;;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index b7db0d01dc1..4ab2ac8e0d4 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -476,4 +476,5 @@ 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/tq.el b/lisp/emacs-lisp/tq.el index 917309e3b98..f7db20859d5 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -1,6 +1,6 @@ ;;; tq.el --- utility to maintain a transaction queue -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1987, 1992, 2003 Free Software Foundation, Inc. ;; Author: Scott Draves <spot@cs.cmu.edu> ;; Maintainer: FSF @@ -50,7 +50,7 @@ to a tcp server on another machine." (process-name process))))))) (set-process-filter process `(lambda (proc string) - (tq-filter '(, tq) string))) + (tq-filter ',tq string))) tq)) ;;; accessors @@ -120,4 +120,5 @@ that's how we tell where the answer ends." (provide 'tq) +;;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 ;;; tq.el ends here diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index b2cbb529809..a6ff9b15286 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -309,4 +309,5 @@ was not traced this is a noop." (provide 'trace) +;;; arch-tag: cfd170a7-4932-4331-8c8b-b7151942e5a1 ;;; trace.el ends here diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 5daa345dbcf..197728d2327 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -259,4 +259,5 @@ is okay if GLOBAL-OKAY is non-nil." (local-variable-p sym))) `(global-variable ,sym)))) +;;; arch-tag: 6216f98b-eb8f-467a-9c33-7a7644f50658 ;; unsafep.el ends here. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 4d0354236a8..e2bf813f9ce 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -25,7 +25,7 @@ ;;; Commentary: ;; This file implements the entry points `warn', `lwarn' -;; and `display-warnings'. +;; and `display-warning'. ;;; Code: @@ -43,7 +43,7 @@ Each element looks like (LEVEL STRING FUNCTION) and defines LEVEL as a severity level. STRING specifies the description of this level. STRING should use `%s' to -specify where to put the warning group information, +specify where to put the warning type information, or it can omit the `%s' so as not to include that information. The optional FUNCTION, if non-nil, is a function to call @@ -91,26 +91,26 @@ the warning is completely ignored." (defcustom warning-suppress-log-types nil "List of warning types that should not be logged. -If any element of this list matches the GROUP argument to `display-warning', +If any element of this list matches the TYPE argument to `display-warning', the warning is completely ignored. -The element must match the first elements of GROUP. +The element must match the first elements of TYPE. Thus, (foo bar) as an element matches (foo bar) -or (foo bar ANYTHING...) as GROUP. -If GROUP is a symbol FOO, that is equivalent to the list (FOO), +or (foo bar ANYTHING...) as TYPE. +If TYPE is a symbol FOO, that is equivalent to the list (FOO), so only the element (FOO) will match it." :group 'warnings :type '(repeat (repeat symbol)) :version "21.4") (defcustom warning-suppress-types nil - "Custom groups for warnings not to display immediately. -If any element of this list matches the GROUP argument to `display-warning', + "List of warning types not to display immediately. +If any element of this list matches the TYPE argument to `display-warning', the warning is logged nonetheless, but the warnings buffer is not immediately displayed. -The element must match an initial segment of the list GROUP. +The element must match an initial segment of the list TYPE. Thus, (foo bar) as an element matches (foo bar) -or (foo bar ANYTHING...) as GROUP. -If GROUP is a symbol FOO, that is equivalent to the list (FOO), +or (foo bar ANYTHING...) as TYPE. +If TYPE is a symbol FOO, that is equivalent to the list (FOO), so only the element (FOO) will match it. See also `warning-suppress-log-types'." :group 'warnings @@ -155,9 +155,9 @@ also call that function before the next warning.") ;;; safely, testing the existing value, before they call one of the ;;; warnings functions. ;;;###autoload -(defvar warning-group-format " (%s)" - "Format for displaying the warning group in the warning message. -The result of formatting the group this way gets included in the +(defvar warning-type-format " (%s)" + "Format for displaying the warning type in the warning message. +The result of formatting the type this way gets included in the message under the control of the string in `warning-levels'.") (defun warning-numeric-level (level) @@ -166,19 +166,19 @@ message under the control of the string in `warning-levels'.") (link (memq elt warning-levels))) (length link))) -(defun warning-suppress-p (group suppress-list) - "Non-nil if a warning with group GROUP should be suppressed. +(defun warning-suppress-p (type suppress-list) + "Non-nil if a warning with type TYPE should be suppressed. SUPPRESS-LIST is the list of kinds of warnings to suppress." (let (some-match) (dolist (elt suppress-list) - (if (symbolp group) - ;; If GROUP is a symbol, the ELT must be (GROUP). + (if (symbolp type) + ;; If TYPE is a symbol, the ELT must be (TYPE). (if (and (consp elt) - (eq (car elt) group) + (eq (car elt) type) (null (cdr elt))) (setq some-match t)) - ;; If GROUP is a list, ELT must match it or some initial segment of it. - (let ((tem1 group) + ;; If TYPE is a list, ELT must match it or some initial segment of it. + (let ((tem1 type) (tem2 elt) (match t)) ;; Check elements of ELT until we run out of them. @@ -187,7 +187,7 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." (setq match nil)) (setq tem1 (cdr tem1) tem2 (cdr tem2))) - ;; If ELT is an initial segment of GROUP, MATCH is t now. + ;; If ELT is an initial segment of TYPE, MATCH is t now. ;; So set SOME-MATCH. (if match (setq some-match t))))) @@ -196,10 +196,10 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress." some-match)) ;;;###autoload -(defun display-warning (group message &optional level buffer-name) +(defun display-warning (type message &optional level buffer-name) "Display a warning message, MESSAGE. -GROUP should be a custom group name (a symbol), -or else a list of symbols whose first element is a custom group name. +TYPE is the warning type: either a custom group name (a symbol), +or a list of symbols whose first element is a custom group name. \(The rest of the symbols represent subcategories, for warning purposes only, and you can use whatever symbols you like.) @@ -224,8 +224,8 @@ See also `warning-series', `warning-prefix-function' and (setq level (cdr (assq level warning-level-aliases)))) (or (< (warning-numeric-level level) (warning-numeric-level warning-minimum-log-level)) - (warning-suppress-p group warning-suppress-log-types) - (let* ((groupname (if (consp group) (car group) group)) + (warning-suppress-p type warning-suppress-log-types) + (let* ((typename (if (consp type) (car type) type)) (buffer (get-buffer-create (or buffer-name "*Warnings*"))) (level-info (assq level warning-levels)) start end) @@ -243,7 +243,7 @@ See also `warning-series', `warning-prefix-function' and (setq level-info (funcall warning-prefix-function level level-info))) (insert (format (nth 1 level-info) - (format warning-group-format groupname)) + (format warning-type-format typename)) message) (newline) (when (and warning-fill-prefix (not (string-match "\n" message))) @@ -273,7 +273,7 @@ See also `warning-series', `warning-prefix-function' and ;; immediate display. (or (< (warning-numeric-level level) (warning-numeric-level warning-minimum-level)) - (warning-suppress-p group warning-suppress-types) + (warning-suppress-p type warning-suppress-types) (let ((window (display-buffer buffer))) (when (and (markerp warning-series) (eq (marker-buffer warning-series) buffer)) @@ -281,13 +281,13 @@ See also `warning-series', `warning-prefix-function' and (sit-for 0))))))) ;;;###autoload -(defun lwarn (group level message &rest args) +(defun lwarn (type level message &rest args) "Display a warning message made from (format MESSAGE ARGS...). Aside from generating the message with `format', this is equivalent to `display-warning'. -GROUP should be a custom group name (a symbol). -or else a list of symbols whose first element is a custom group name. +TYPE is the warning type: either a custom group name (a symbol). +or a list of symbols whose first element is a custom group name. \(The rest of the symbols represent subcategories and can be whatever you like.) @@ -296,16 +296,17 @@ LEVEL should be either :warning, :error, or :emergency. if you do not attend to it promptly. :error -- invalid data or circumstances. :warning -- suspicious data or circumstances." - (display-warning group (apply 'format message args) level)) + (display-warning type (apply 'format message args) level)) ;;;###autoload (defun warn (message &rest args) "Display a warning message made from (format MESSAGE ARGS...). Aside from generating the message with `format', this is equivalent to `display-warning', using -`emacs' as the group and `:warning' as the level." +`emacs' as the type and `:warning' as the level." (display-warning 'emacs (apply 'format message args))) (provide 'warnings) +;;; arch-tag: faaad1c8-7b2a-4161-af38-5ab4afde0496 ;;; warnings.el ends here |