aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
authorDaniel Colascione <[email protected]>2012-09-17 04:07:36 -0800
committerDaniel Colascione <[email protected]>2012-09-17 04:07:36 -0800
commit2ab329f3b5d52a39f0a45c3d9c129f1c19560142 (patch)
tree6dd6784d63e54cb18071df8e28fbdbc27d418728 /lisp/emacs-lisp
parentf701ab72dd55460d23c8b029550aa4d7ecef3cfa (diff)
parentbb7dce392f6d9d5fc4b9d7de09ff920a52f07669 (diff)
Merge from trunk
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/advice.el193
-rw-r--r--lisp/emacs-lisp/benchmark.el6
-rw-r--r--lisp/emacs-lisp/byte-run.el9
-rw-r--r--lisp/emacs-lisp/bytecomp.el4
-rw-r--r--lisp/emacs-lisp/cl-lib.el2
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el28
-rw-r--r--lisp/emacs-lisp/cl-macs.el83
-rw-r--r--lisp/emacs-lisp/debug.el198
-rw-r--r--lisp/emacs-lisp/easymenu.el2
-rw-r--r--lisp/emacs-lisp/edebug.el751
-rw-r--r--lisp/emacs-lisp/lisp-mode.el77
-rw-r--r--lisp/emacs-lisp/macroexp.el110
-rw-r--r--lisp/emacs-lisp/map-ynp.el10
-rw-r--r--lisp/emacs-lisp/pcase.el2
-rw-r--r--lisp/emacs-lisp/timer.el6
15 files changed, 717 insertions, 764 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index cac76d2bce..d96076d17a 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1,4 +1,4 @@
-;;; advice.el --- an overloading mechanism for Emacs Lisp functions
+;;; advice.el --- An overloading mechanism for Emacs Lisp functions
;; Copyright (C) 1993-1994, 2000-2012 Free Software Foundation, Inc.
@@ -1746,7 +1746,8 @@
(provide 'advice-preload)
;; During a normal load this is a noop:
(require 'advice-preload "advice.el")
-
+(require 'macroexp)
+(eval-when-compile (require 'cl-lib))
;; @@ Variable definitions:
;; ========================
@@ -1812,54 +1813,6 @@ generates a copy of TREE."
(funcall fUnCtIoN tReE))
(t tReE)))
-;; this is just faster than `ad-substitute-tree':
-(defun ad-copy-tree (tree)
- "Return a copy of the list structure of TREE."
- (cond ((consp tree)
- (cons (ad-copy-tree (car tree))
- (ad-copy-tree (cdr tree))))
- (t tree)))
-
-(defmacro ad-dolist (varform &rest body)
- "A Common-Lisp-style dolist iterator with the following syntax:
-
- (ad-dolist (VAR INIT-FORM [RESULT-FORM])
- BODY-FORM...)
-
-which will iterate over the list yielded by INIT-FORM binding VAR to the
-current head at every iteration. If RESULT-FORM is supplied its value will
-be returned at the end of the iteration, nil otherwise. The iteration can be
-exited prematurely with `(ad-do-return [VALUE])'."
- (let ((expansion
- `(let ((ad-dO-vAr ,(car (cdr varform)))
- ,(car varform))
- (while ad-dO-vAr
- (setq ,(car varform) (car ad-dO-vAr))
- ,@body
- ;;work around a backquote bug:
- ;;(` ((,@ '(foo)) (bar))) => (append '(foo) '(((bar)))) wrong
- ;;(` ((,@ '(foo)) (, '(bar)))) => (append '(foo) (list '(bar)))
- ,'(setq ad-dO-vAr (cdr ad-dO-vAr)))
- ,(car (cdr (cdr varform))))))
- ;;ok, this wastes some cons cells but only during compilation:
- (if (catch 'contains-return
- (ad-substitute-tree
- (function (lambda (subtree)
- (cond ((eq (car-safe subtree) 'ad-dolist))
- ((eq (car-safe subtree) 'ad-do-return)
- (throw 'contains-return t)))))
- 'identity body)
- nil)
- `(catch 'ad-dO-eXiT ,expansion)
- expansion)))
-
-(defmacro ad-do-return (value)
- `(throw 'ad-dO-eXiT ,value))
-
-(if (not (get 'ad-dolist 'lisp-indent-hook))
- (put 'ad-dolist 'lisp-indent-hook 1))
-
-
;; @@ Save real definitions of subrs used by Advice:
;; =================================================
;; Advice depends on the real, unmodified functionality of various subrs,
@@ -1924,16 +1877,16 @@ exited prematurely with `(ad-do-return [VALUE])'."
ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
- "`ad-dolist'-style iterator that maps over `ad-advised-functions'.
+ "`dolist'-style iterator that maps over `ad-advised-functions'.
\(ad-do-advised-functions (VAR [RESULT-FORM])
BODY-FORM...)
On each iteration VAR will be bound to the name of an advised function
\(a symbol)."
- `(ad-dolist (,(car varform)
+ `(cl-dolist (,(car varform)
ad-advised-functions
,(car (cdr varform)))
- (setq ,(car varform) (intern (car ,(car varform))))
- ,@body))
+ (setq ,(car varform) (intern (car ,(car varform))))
+ ,@body))
(if (not (get 'ad-do-advised-functions 'lisp-indent-hook))
(put 'ad-do-advised-functions 'lisp-indent-hook 1))
@@ -1948,7 +1901,7 @@ On each iteration VAR will be bound to the name of an advised function
`(put ,function 'ad-advice-info ,advice-info))
(defmacro ad-copy-advice-info (function)
- `(ad-copy-tree (get ,function 'ad-advice-info)))
+ `(copy-tree (get ,function 'ad-advice-info)))
(defmacro ad-is-advised (function)
"Return non-nil if FUNCTION has any advice info associated with it.
@@ -2022,8 +1975,8 @@ either t or nil, and DEFINITION should be a list of the form
(defun ad-has-enabled-advice (function class)
"True if at least one of FUNCTION's advices in CLASS is enabled."
- (ad-dolist (advice (ad-get-advice-info-field function class))
- (if (ad-advice-enabled advice) (ad-do-return t))))
+ (cl-dolist (advice (ad-get-advice-info-field function class))
+ (if (ad-advice-enabled advice) (cl-return t))))
(defun ad-has-redefining-advice (function)
"True if FUNCTION's advice info defines at least 1 redefining advice.
@@ -2036,14 +1989,14 @@ Redefining advices affect the construction of an advised definition."
(defun ad-has-any-advice (function)
"True if the advice info of FUNCTION defines at least one advice."
(and (ad-is-advised function)
- (ad-dolist (class ad-advice-classes nil)
+ (cl-dolist (class ad-advice-classes nil)
(if (ad-get-advice-info-field function class)
- (ad-do-return t)))))
+ (cl-return t)))))
(defun ad-get-enabled-advices (function class)
"Return the list of enabled advices of FUNCTION in CLASS."
(let (enabled-advices)
- (ad-dolist (advice (ad-get-advice-info-field function class))
+ (dolist (advice (ad-get-advice-info-field function class))
(if (ad-advice-enabled advice)
(push advice enabled-advices)))
(reverse enabled-advices)))
@@ -2151,7 +2104,7 @@ function at point for which PREDICATE returns non-nil)."
(ad-do-advised-functions (function)
(if (or (null predicate)
(funcall predicate function))
- (ad-do-return function)))
+ (cl-return function)))
(error "ad-read-advised-function: %s"
"There are no qualifying advised functions")))
(let* ((ad-pReDiCaTe predicate)
@@ -2184,9 +2137,9 @@ be returned on empty input (defaults to the first non-empty advice
class of FUNCTION)."
(setq default
(or default
- (ad-dolist (class ad-advice-classes)
+ (cl-dolist (class ad-advice-classes)
(if (ad-get-advice-info-field function class)
- (ad-do-return class)))
+ (cl-return class)))
(error "ad-read-advice-class: `%s' has no advices" function)))
(let ((class (completing-read
(format "%s (default %s): " (or prompt "Class") default)
@@ -2255,18 +2208,18 @@ NAME can be a symbol or a regular expression matching part of an advice name.
If CLASS is `any' all valid advice classes will be checked."
(if (ad-is-advised function)
(let (found-advice)
- (ad-dolist (advice-class ad-advice-classes)
+ (cl-dolist (advice-class ad-advice-classes)
(if (or (eq class 'any) (eq advice-class class))
(setq found-advice
- (ad-dolist (advice (ad-get-advice-info-field
+ (cl-dolist (advice (ad-get-advice-info-field
function advice-class))
(if (or (and (stringp name)
(string-match
name (symbol-name
(ad-advice-name advice))))
(eq name (ad-advice-name advice)))
- (ad-do-return advice)))))
- (if found-advice (ad-do-return found-advice))))))
+ (cl-return advice)))))
+ (if found-advice (cl-return found-advice))))))
(defun ad-enable-advice-internal (function class name flag)
"Set enable FLAG of FUNCTION's advices in CLASS matching NAME.
@@ -2277,10 +2230,10 @@ considered. The number of changed advices will be returned (or nil if
FUNCTION was not advised)."
(if (ad-is-advised function)
(let ((matched-advices 0))
- (ad-dolist (advice-class ad-advice-classes)
+ (dolist (advice-class ad-advice-classes)
(if (or (eq class 'any) (eq advice-class class))
- (ad-dolist (advice (ad-get-advice-info-field
- function advice-class))
+ (dolist (advice (ad-get-advice-info-field
+ function advice-class))
(cond ((or (and (stringp name)
(string-match
name (symbol-name (ad-advice-name advice))))
@@ -2586,11 +2539,6 @@ For that it has to be fbound with a non-autoload definition."
(byte-compile symbol)
(fset function (symbol-function symbol))))))
-(defun ad-prognify (forms)
- (cond ((<= (length forms) 1)
- (car forms))
- (t (cons 'progn forms))))
-
;; @@@ Accessing argument lists:
;; =============================
@@ -2868,8 +2816,8 @@ in any of these classes."
(if origdoc (setq paragraphs (list origdoc)))
(unless (eq style 'plain)
(push (concat "This " origtype " is advised.") paragraphs))
- (ad-dolist (class ad-advice-classes)
- (ad-dolist (advice (ad-get-enabled-advices function class))
+ (dolist (class ad-advice-classes)
+ (dolist (advice (ad-get-enabled-advices function class))
(setq advice-docstring
(ad-make-single-advice-docstring advice class style))
(if advice-docstring
@@ -2891,24 +2839,24 @@ in any of these classes."
(defun ad-advised-arglist (function)
"Find first defined arglist in FUNCTION's redefining advices."
- (ad-dolist (advice (append (ad-get-enabled-advices function 'before)
+ (cl-dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
(let ((arglist (ad-arglist (ad-advice-definition advice))))
(if arglist
;; We found the first one, use it:
- (ad-do-return arglist)))))
+ (cl-return arglist)))))
(defun ad-advised-interactive-form (function)
"Find first interactive form in FUNCTION's redefining advices."
- (ad-dolist (advice (append (ad-get-enabled-advices function 'before)
+ (cl-dolist (advice (append (ad-get-enabled-advices function 'before)
(ad-get-enabled-advices function 'around)
(ad-get-enabled-advices function 'after)))
(let ((interactive-form
(ad-interactive-form (ad-advice-definition advice))))
(if interactive-form
;; We found the first one, use it:
- (ad-do-return interactive-form)))))
+ (cl-return interactive-form)))))
;; @@@ Putting it all together:
;; ============================
@@ -2997,47 +2945,47 @@ and BEFORES, AROUNDS and AFTERS are the lists of advices with which ORIG
should be modified. The assembled function will be returned."
(let (before-forms around-form around-form-protected after-forms definition)
- (ad-dolist (advice befores)
- (cond ((and (ad-advice-protected advice)
- before-forms)
- (setq before-forms
- `((unwind-protect
- ,(ad-prognify before-forms)
- ,@(ad-body-forms
- (ad-advice-definition advice))))))
- (t (setq before-forms
- (append before-forms
- (ad-body-forms (ad-advice-definition advice)))))))
+ (dolist (advice befores)
+ (cond ((and (ad-advice-protected advice)
+ before-forms)
+ (setq before-forms
+ `((unwind-protect
+ ,(macroexp-progn before-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq before-forms
+ (append before-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
(setq around-form `(setq ad-return-value ,orig))
- (ad-dolist (advice (reverse arounds))
- ;; If any of the around advices is protected then we
- ;; protect the complete around advice onion:
- (if (ad-advice-protected advice)
- (setq around-form-protected t))
- (setq around-form
- (ad-substitute-tree
- (function (lambda (form) (eq form 'ad-do-it)))
- (function (lambda (form) around-form))
- (ad-prognify (ad-body-forms (ad-advice-definition advice))))))
+ (dolist (advice (reverse arounds))
+ ;; If any of the around advices is protected then we
+ ;; protect the complete around advice onion:
+ (if (ad-advice-protected advice)
+ (setq around-form-protected t))
+ (setq around-form
+ (ad-substitute-tree
+ (function (lambda (form) (eq form 'ad-do-it)))
+ (function (lambda (form) around-form))
+ (macroexp-progn (ad-body-forms (ad-advice-definition advice))))))
(setq after-forms
(if (and around-form-protected before-forms)
`((unwind-protect
- ,(ad-prognify before-forms)
+ ,(macroexp-progn before-forms)
,around-form))
(append before-forms (list around-form))))
- (ad-dolist (advice afters)
- (cond ((and (ad-advice-protected advice)
- after-forms)
- (setq after-forms
- `((unwind-protect
- ,(ad-prognify after-forms)
- ,@(ad-body-forms
- (ad-advice-definition advice))))))
- (t (setq after-forms
- (append after-forms
- (ad-body-forms (ad-advice-definition advice)))))))
+ (dolist (advice afters)
+ (cond ((and (ad-advice-protected advice)
+ after-forms)
+ (setq after-forms
+ `((unwind-protect
+ ,(macroexp-progn after-forms)
+ ,@(ad-body-forms
+ (ad-advice-definition advice))))))
+ (t (setq after-forms
+ (append after-forms
+ (ad-body-forms (ad-advice-definition advice)))))))
(setq definition
`(,@(if (memq type '(macro special-form)) '(macro))
@@ -3061,7 +3009,7 @@ should be modified. The assembled function will be returned."
(ad-body-forms (ad-advice-definition advice))))
(ad-get-enabled-advices function hook-name))))
(if hook-forms
- (ad-prognify (apply 'append hook-forms)))))
+ (macroexp-progn (apply 'append hook-forms)))))
;; @@ Caching:
@@ -3171,11 +3119,11 @@ advised definition from scratch."
(nth 2 cache-id)))))
(defun ad-verify-cache-class-id (cache-class-id advices)
- (ad-dolist (advice advices (null cache-class-id))
+ (cl-dolist (advice advices (null cache-class-id))
(if (ad-advice-enabled advice)
(if (eq (car cache-class-id) (ad-advice-name advice))
(setq cache-class-id (cdr cache-class-id))
- (ad-do-return nil)))))
+ (cl-return nil)))))
;; There should be a way to monitor if and why a cache verification failed
;; in order to determine whether a certain preactivation could be used or
@@ -3670,7 +3618,16 @@ See Info node `(elisp)Advising Functions' for comprehensive documentation.
usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
[DOCSTRING] [INTERACTIVE-FORM]
BODY...)"
- (declare (doc-string 3))
+ (declare (doc-string 3)
+ (debug (&define name ;; thing being advised.
+ (name ;; class is [&or "before" "around" "after"
+ ;; "activation" "deactivation"]
+ name ;; name of advice
+ &rest sexp ;; optional position and flags
+ )
+ [&optional stringp]
+ [&optional ("interactive" interactive)]
+ def-body)))
(if (not (ad-name-p function))
(error "defadvice: Invalid function name: %s" function))
(let* ((class (car args))
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 646be3e1b7..9029c81f27 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -53,6 +53,7 @@ FORMS once.
Return a list of the total elapsed time for execution, the number of
garbage collections that ran, and the time taken by garbage collection.
See also `benchmark-run-compiled'."
+ (declare (indent 1) (debug t))
(unless (natnump repetitions)
(setq forms (cons repetitions forms)
repetitions 1))
@@ -69,8 +70,6 @@ See also `benchmark-run-compiled'."
`(benchmark-elapse ,@forms))
(- gcs-done ,gcs)
(- gc-elapsed ,gc)))))
-(put 'benchmark-run 'edebug-form-spec t)
-(put 'benchmark-run 'lisp-indent-function 2)
;;;###autoload
(defmacro benchmark-run-compiled (&optional repetitions &rest forms)
@@ -78,6 +77,7 @@ See also `benchmark-run-compiled'."
This is like `benchmark-run', but what is timed is a funcall of the
byte code obtained by wrapping FORMS in a `lambda' and compiling the
result. The overhead of the `lambda's is accounted for."
+ (declare (indent 1) (debug t))
(unless (natnump repetitions)
(setq forms (cons repetitions forms)
repetitions 1))
@@ -96,8 +96,6 @@ result. The overhead of the `lambda's is accounted for."
(funcall ,lambda-code))))
`(benchmark-elapse (funcall ,code)))
(- gcs-done ,gcs) (- gc-elapsed ,gc)))))
-(put 'benchmark-run-compiled 'edebug-form-spec t)
-(put 'benchmark-run-compiled 'lisp-indent-function 2)
;;;###autoload
(defun benchmark (repetitions form)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 9b66c8ffd6..93e890a20c 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -185,11 +185,10 @@ The return value is undefined.
((and (featurep 'cl)
(memq (car x) ;C.f. cl-do-proclaim.
'(special inline notinline optimize warn)))
- (if (null (stringp docstring))
- (push (list 'declare x) body)
- (setcdr body (cons (list 'declare x) (cdr body))))
+ (push (list 'declare x)
+ (if (stringp docstring) (cdr body) body))
nil)
- (t (message "Warning: Unknown defun property %S in %S"
+ (t (message "Warning: Unknown defun property `%S' in %S"
(car x) name)))))
decls))
(def (list 'defalias
@@ -313,7 +312,7 @@ This uses `defvaralias' and `make-obsolete-variable' (which see).
See the Info node `(elisp)Variable Aliases' for more details.
If CURRENT-NAME is a defcustom (more generally, any variable
-where OBSOLETE-NAME may be set, e.g. in a .emacs file, before the
+where OBSOLETE-NAME may be set, e.g. in an init file, before the
alias is defined), then the define-obsolete-variable-alias
statement should be evaluated before the defcustom, if user
customizations are to be respected. The simplest way to achieve
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 10bc37c6dc..c42ae21aae 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1016,6 +1016,10 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
((bufferp byte-compile-current-file)
(format "Buffer %s:"
(buffer-name byte-compile-current-file)))
+ ;; We might be simply loading a file that
+ ;; contains explicit calls to byte-compile functions.
+ ((stringp load-file-name)
+ (format "%s:" (file-relative-name load-file-name dir)))
(t "")))
(pos (if (and byte-compile-current-file
(integerp byte-compile-read-position))
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 532c81c502..5749ff91b4 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -121,7 +121,7 @@ a future Emacs interpreter will be able to use it.")
;;; Generalized variables.
;; These macros are defined here so that they
-;; can safely be used in .emacs files.
+;; can safely be used in init files.
(defmacro cl-incf (place &optional x)
"Increment PLACE by X (1 by default).
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 470ca17d3a..c12e8ccacb 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -249,8 +249,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;***
-;;;### (autoloads (cl--compiler-macro-cXXr cl--compiler-macro-list*
-;;;;;; cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand
+;;;### (autoloads (cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand
;;;;;; cl-define-compiler-macro cl-assert cl-check-type cl-typep
;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf cl-letf* cl-letf
;;;;;; cl-rotatef cl-shiftf cl-remf cl-psetf cl-declare cl-the cl-locally
@@ -260,9 +259,20 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;;;; cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase
;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
-;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9676d5517e8b9246c09fe78984c68bef")
+;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
+;;;;;; "cl-macs" "cl-macs.el" "6d0676869af66e5b5a671f95ee069461")
;;; Generated autoloads from cl-macs.el
+(autoload 'cl--compiler-macro-list* "cl-macs" "\
+
+
+\(fn FORM ARG &rest OTHERS)" nil nil)
+
+(autoload 'cl--compiler-macro-cXXr "cl-macs" "\
+
+
+\(fn FORM X)" nil nil)
+
(autoload 'cl-gensym "cl-macs" "\
Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\".
@@ -659,6 +669,8 @@ value, that slot cannot be set via `setf'.
(put 'cl-defstruct 'doc-string-elt '2)
+(put 'cl-defstruct 'lisp-indent-function '1)
+
(autoload 'cl-deftype "cl-macs" "\
Define NAME as a new data type.
The type name can then be used in `cl-typecase', `cl-check-type', etc.
@@ -722,16 +734,6 @@ surrounded by (cl-block NAME ...).
\(fn FORM A LIST &rest KEYS)" nil nil)
-(autoload 'cl--compiler-macro-list* "cl-macs" "\
-
-
-\(fn FORM ARG &rest OTHERS)" nil nil)
-
-(autoload 'cl--compiler-macro-cXXr "cl-macs" "\
-
-
-\(fn FORM X)" nil nil)
-
;;;***
;;;### (autoloads (cl-tree-equal cl-nsublis cl-sublis cl-nsubst-if-not
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 9a59aa0c6d..16ac14f8fe 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -58,6 +58,33 @@
;;; Initialization.
+;; Place compiler macros at the beginning, otherwise uses of the corresponding
+;; functions can lead to recursive-loads that prevent the calls from
+;; being optimized.
+
+;;;###autoload
+(defun cl--compiler-macro-list* (_form arg &rest others)
+ (let* ((args (reverse (cons arg others)))
+ (form (car args)))
+ (while (setq args (cdr args))
+ (setq form `(cons ,(car args) ,form)))
+ form))
+
+;;;###autoload
+(defun cl--compiler-macro-cXXr (form x)
+ (let* ((head (car form))
+ (n (symbol-name (car form)))
+ (i (- (length n) 2)))
+ (if (not (string-match "c[ad]+r\\'" n))
+ (if (and (fboundp head) (symbolp (symbol-function head)))
+ (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
+ x)
+ (error "Compiler macro for cXXr applied to non-cXXr form"))
+ (while (> i (match-beginning 0))
+ (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
+ (setq i (1- i)))
+ x)))
+
;;; Some predicates for analyzing Lisp forms.
;; These are used by various
;; macro expanders to optimize the results in certain common cases.
@@ -366,9 +393,14 @@ its argument list allows full Common Lisp conventions."
(mapcar (lambda (x)
(cond
((symbolp x)
- (if (eq ?\& (aref (symbol-name x) 0))
- (setq state x)
- (make-symbol (upcase (symbol-name x)))))
+ (let ((first (aref (symbol-name x) 0)))
+ (if (eq ?\& first)
+ (setq state x)
+ ;; Strip a leading underscore, since it only
+ ;; means that this argument is unused.
+ (make-symbol (upcase (if (eq ?_ first)
+ (substring (symbol-name x) 1)
+ (symbol-name x)))))))
((not (consp x)) x)
((memq state '(nil &rest)) (cl--make-usage-args x))
(t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
@@ -452,7 +484,13 @@ its argument list allows full Common Lisp conventions."
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
- (intern (format ":%s" (car arg)))))
+ (let ((name (symbol-name (car arg))))
+ ;; Strip a leading underscore, since it only
+ ;; means that this argument is unused, but
+ ;; shouldn't affect the key's name (bug#12367).
+ (if (eq ?_ (aref name 0))
+ (setq name (substring name 1)))
+ (intern (format ":%s" name)))))
(varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
(or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
@@ -1425,8 +1463,15 @@ Valid clauses are:
cl--loop-accum-var))))
(defun cl--loop-build-ands (clauses)
+ "Return various representations of (and . CLAUSES).
+CLAUSES is a list of Elisp expressions, where clauses of the form
+\(progn E1 E2 E3 .. t) are the focus of particular optimizations.
+The return value has shape (COND BODY COMBO)
+such that COMBO is equivalent to (and . CLAUSES)."
(let ((ands nil)
(body nil))
+ ;; Look through `clauses', trying to optimize (progn ,@A t) (progn ,@B) ,@C
+ ;; into (progn ,@A ,@B) ,@C.
(while clauses
(if (and (eq (car-safe (car clauses)) 'progn)
(eq (car (last (car clauses))) t))
@@ -1437,6 +1482,7 @@ Valid clauses are:
(cl-cdadr clauses)
(list (cadr clauses))))
(cddr clauses)))
+ ;; A final (progn ,@A t) is moved outside of the `and'.
(setq body (cdr (butlast (pop clauses)))))
(push (pop clauses) ands)))
(setq ands (or (nreverse ands) (list t)))
@@ -1905,8 +1951,6 @@ See Info node `(cl)Declarations' for details."
(cl-do-proclaim (pop specs) nil)))
nil)
-
-
;;; The standard modify macros.
;; `setf' is now part of core Elisp, defined in gv.el.
@@ -1929,7 +1973,7 @@ before assigning any PLACEs to the corresponding values.
(or p (error "Odd number of arguments to cl-psetf"))
(pop p))
(if simple
- `(progn (setf ,@args) nil)
+ `(progn (setq ,@args) nil)
(setq args (reverse args))
(let ((expr `(setf ,(cadr args) ,(car args))))
(while (setq args (cddr args))
@@ -2119,7 +2163,7 @@ one keyword is supported, `:read-only'. If this has a non-nil
value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
- (declare (doc-string 2)
+ (declare (doc-string 2) (indent 1)
(debug
(&define ;Makes top-level form not be wrapped.
[&or symbolp
@@ -2597,14 +2641,6 @@ surrounded by (cl-block NAME ...).
`(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list))
form))
-;;;###autoload
-(defun cl--compiler-macro-list* (_form arg &rest others)
- (let* ((args (reverse (cons arg others)))
- (form (car args)))
- (while (setq args (cdr args))
- (setq form `(cons ,(car args) ,form)))
- form))
-
(defun cl--compiler-macro-get (_form sym prop &optional def)
(if def
`(cl-getf (symbol-plist ,sym) ,prop ,def)
@@ -2616,21 +2652,6 @@ surrounded by (cl-block NAME ...).
(cl--make-type-test temp (cl--const-expr-val type)))
form))
-;;;###autoload
-(defun cl--compiler-macro-cXXr (form x)
- (let* ((head (car form))
- (n (symbol-name (car form)))
- (i (- (length n) 2)))
- (if (not (string-match "c[ad]+r\\'" n))
- (if (and (fboundp head) (symbolp (symbol-function head)))
- (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
- x)
- (error "Compiler macro for cXXr applied to non-cXXr form"))
- (while (> i (match-beginning 0))
- (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
- (setq i (1- i)))
- x)))
-
(dolist (y '(cl-first cl-second cl-third cl-fourth
cl-fifth cl-sixth cl-seventh
cl-eighth cl-ninth cl-tenth
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 7bc93a19d1..774b4d3d60 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -48,6 +48,39 @@ the middle is discarded, and just the beginning and end are displayed."
:group 'debugger
:version "21.1")
+(defcustom debugger-bury-or-kill 'bury
+ "How to proceed with the debugger buffer when exiting `debug'.
+The value used here affects the behavior of operations on any
+window previously showing the debugger buffer.
+
+`nil' means that if its window is not deleted when exiting the
+ debugger, invoking `switch-to-prev-buffer' will usually show
+ the debugger buffer again.
+
+`append' means that if the window is not deleted, the debugger
+ buffer moves to the end of the window's previous buffers so
+ it's less likely that a future invocation of
+ `switch-to-prev-buffer' will switch to it. Also, it moves the
+ buffer to the end of the frame's buffer list.
+
+`bury' means that if the window is not deleted, its buffer is
+ removed from the window's list of previous buffers. Also, it
+ moves the buffer to the end of the frame's buffer list. This
+ value provides the most reliable remedy to not have
+ `switch-to-prev-buffer' switch to the debugger buffer again
+ without killing the buffer.
+
+`kill' means to kill the debugger buffer.
+
+The value used here is passed to `quit-restore-window'."
+ :type '(choice
+ (const :tag "Keep alive" nil)
+ (const :tag "Append" 'append)
+ (const :tag "Bury" 'bury)
+ (const :tag "Kill" 'kill))
+ :group 'debugger
+ :version "24.2")
+
(defvar debug-function-list nil
"List of functions currently set for debug on entry.")
@@ -60,6 +93,12 @@ the middle is discarded, and just the beginning and end are displayed."
(defvar debugger-old-buffer nil
"This is the buffer that was current when the debugger was entered.")
+(defvar debugger-previous-window nil
+ "This is the window last showing the debugger buffer.")
+
+(defvar debugger-previous-window-height nil
+ "The last recorded height of `debugger-previous-window'.")
+
(defvar debugger-previous-backtrace nil
"The contents of the previous backtrace (including text properties).
This is to optimize `debugger-make-xrefs'.")
@@ -71,10 +110,6 @@ This is to optimize `debugger-make-xrefs'.")
(defvar debugger-outer-track-mouse)
(defvar debugger-outer-last-command)
(defvar debugger-outer-this-command)
-;; unread-command-char is obsolete,
-;; but we still save and restore it
-;; in case some user program still tries to set it.
-(defvar debugger-outer-unread-command-char)
(defvar debugger-outer-unread-command-events)
(defvar debugger-outer-unread-post-input-method-events)
(defvar debugger-outer-last-input-event)
@@ -126,14 +161,12 @@ first will be printed into the backtrace buffer."
(unless noninteractive
(message "Entering debugger..."))
(let (debugger-value
- (debug-on-error nil)
- (debug-on-quit nil)
(debugger-previous-state
(if (get-buffer "*Backtrace*")
(with-current-buffer (get-buffer "*Backtrace*")
(list major-mode (buffer-string)))))
(debugger-buffer (get-buffer-create "*Backtrace*"))
- (debugger-old-buffer (current-buffer))
+ (debugger-window nil)
(debugger-step-after-exit nil)
(debugger-will-be-back nil)
;; Don't keep reading from an executing kbd macro!
@@ -148,8 +181,6 @@ first will be printed into the backtrace buffer."
(debugger-outer-track-mouse track-mouse)
(debugger-outer-last-command last-command)
(debugger-outer-this-command this-command)
- (debugger-outer-unread-command-char
- (with-no-warnings unread-command-char))
(debugger-outer-unread-command-events unread-command-events)
(debugger-outer-unread-post-input-method-events
unread-post-input-method-events)
@@ -184,78 +215,74 @@ first will be printed into the backtrace buffer."
(cursor-in-echo-area nil))
(unwind-protect
(save-excursion
- (save-window-excursion
- (with-no-warnings
- (setq unread-command-char -1))
- (when (eq (car debugger-args) 'debug)
- ;; Skip the frames for backtrace-debug, byte-code,
- ;; and implement-debug-on-entry.
- (backtrace-debug 4 t)
- ;; Place an extra debug-on-exit for macro's.
- (when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
- (backtrace-debug 5 t)))
- (pop-to-buffer debugger-buffer)
- (debugger-mode)
- (debugger-setup-buffer debugger-args)
- (when noninteractive
- ;; If the backtrace is long, save the beginning
- ;; and the end, but discard the middle.
- (when (> (count-lines (point-min) (point-max))
- debugger-batch-max-lines)
- (goto-char (point-min))
- (forward-line (/ 2 debugger-batch-max-lines))
- (let ((middlestart (point)))
- (goto-char (point-max))
- (forward-line (- (/ 2 debugger-batch-max-lines)
- debugger-batch-max-lines))
- (delete-region middlestart (point)))
- (insert "...\n"))
+ (when (eq (car debugger-args) 'debug)
+ ;; Skip the frames for backtrace-debug, byte-code,
+ ;; and implement-debug-on-entry.
+ (backtrace-debug 4 t)
+ ;; Place an extra debug-on-exit for macro's.
+ (when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
+ (backtrace-debug 5 t)))
+ (pop-to-buffer
+ debugger-buffer
+ `((display-buffer-reuse-window
+ display-buffer-in-previous-window)
+ . (,(when debugger-previous-window
+ `(previous-window . ,debugger-previous-window)))))
+ (setq debugger-window (selected-window))
+ (if (eq debugger-previous-window debugger-window)
+ (when debugger-jumping-flag
+ ;; Try to restore previous height of debugger
+ ;; window.
+ (condition-case nil
+ (window-resize
+ debugger-window
+ (- debugger-previous-window-height
+ (window-total-size debugger-window)))
+ (error nil)))
+ (setq debugger-previous-window debugger-window))
+ (debugger-mode)
+ (debugger-setup-buffer debugger-args)
+ (when noninteractive
+ ;; If the backtrace is long, save the beginning
+ ;; and the end, but discard the middle.
+ (when (> (count-lines (point-min) (point-max))
+ debugger-batch-max-lines)
(goto-char (point-min))
- (message "%s" (buffer-string))
- (kill-emacs -1))
+ (forward-line (/ 2 debugger-batch-max-lines))
+ (let ((middlestart (point)))
+ (goto-char (point-max))
+ (forward-line (- (/ 2 debugger-batch-max-lines)
+ debugger-batch-max-lines))
+ (delete-region middlestart (point)))
+ (insert "...\n"))
+ (goto-char (point-min))
+ (message "%s" (buffer-string))
+ (kill-emacs -1))
+ (message "")
+ (let ((standard-output nil)
+ (buffer-read-only t))
(message "")
- (let ((standard-output nil)
- (buffer-read-only t))
- (message "")
- ;; Make sure we unbind buffer-read-only in the right buffer.
- (save-excursion
- (recursive-edit)))))
- ;; Kill or at least neuter the backtrace buffer, so that users
- ;; don't try to execute debugger commands in an invalid context.
- (if (get-buffer-window debugger-buffer 0)
- ;; Still visible despite the save-window-excursion? Maybe it
- ;; it's in a pop-up frame. It would be annoying to delete and
- ;; recreate it every time the debugger stops, so instead we'll
- ;; erase it (and maybe hide it) but keep it alive.
- (with-current-buffer debugger-buffer
- (with-selected-window (get-buffer-window debugger-buffer 0)
- (when (and (window-dedicated-p (selected-window))
- (not debugger-will-be-back))
- ;; If the window is not dedicated, burying the buffer
- ;; will mean that the frame created for it is left
- ;; around showing some random buffer, and next time we
- ;; pop to the debugger buffer we'll create yet
- ;; another frame.
- ;; If debugger-will-be-back is non-nil, the frame
- ;; would need to be de-iconified anyway immediately
- ;; after when we re-enter the debugger, so iconifying it
- ;; here would cause flashing.
- ;; Drew Adams is not happy with this: he wants to frame
- ;; to be left at the top-level, still working on how
- ;; best to do that.
- (bury-buffer))))
- (unless debugger-previous-state
- (kill-buffer debugger-buffer)))
- ;; Restore the previous state of the debugger-buffer, in case we were
- ;; in a recursive invocation of the debugger.
- (when (buffer-live-p debugger-buffer)
- (with-current-buffer debugger-buffer
- (let ((inhibit-read-only t))
- (erase-buffer)
- (if (null debugger-previous-state)
- (fundamental-mode)
- (insert (nth 1 debugger-previous-state))
- (funcall (nth 0 debugger-previous-state))))))
+ ;; Make sure we unbind buffer-read-only in the right buffer.
+ (save-excursion
+ (recursive-edit))))
+ (when (and (window-live-p debugger-window)
+ (eq (window-buffer debugger-window) debugger-buffer))
+ ;; Record height of debugger window.
+ (setq debugger-previous-window-height
+ (window-total-size debugger-window))
+ ;; Unshow debugger-buffer.
+ (quit-restore-window debugger-window debugger-bury-or-kill))
+ ;; Restore previous state of debugger-buffer in case we were
+ ;; in a recursive invocation of the debugger, otherwise just
+ ;; erase the buffer and put it into fundamental mode.
+ (when (buffer-live-p debugger-buffer)
+ (with-current-buffer debugger-buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (if (null debugger-previous-state)
+ (fundamental-mode)
+ (insert (nth 1 debugger-previous-state))
+ (funcall (nth 0 debugger-previous-state))))))
(with-timeout-unsuspend debugger-with-timeout-suspend)
(set-match-data debugger-outer-match-data)))
;; Put into effect the modified values of these variables
@@ -267,8 +294,6 @@ first will be printed into the backtrace buffer."
(setq track-mouse debugger-outer-track-mouse)
(setq last-command debugger-outer-last-command)
(setq this-command debugger-outer-this-command)
- (with-no-warnings
- (setq unread-command-char debugger-outer-unread-command-char))
(setq unread-command-events debugger-outer-unread-command-events)
(setq unread-post-input-method-events
debugger-outer-unread-post-input-method-events)
@@ -570,16 +595,7 @@ Applies to the frame whose line point is on in the backtrace."
(cursor-in-echo-area debugger-outer-cursor-in-echo-area))
(set-match-data debugger-outer-match-data)
(prog1
- (let ((save-ucc (with-no-warnings unread-command-char)))
- (unwind-protect
- (progn
- (with-no-warnings
- (setq unread-command-char debugger-outer-unread-command-char))
- (prog1 (progn ,@body)
- (with-no-warnings
- (setq debugger-outer-unread-command-char unread-command-char))))
- (with-no-warnings
- (setq unread-command-char save-ucc))))
+ (progn ,@body)
(setq debugger-outer-match-data (match-data))
(setq debugger-outer-load-read-function load-read-function)
(setq debugger-outer-overriding-terminal-local-map
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 7f9f8a3363..939fab7894 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -148,7 +148,7 @@ unselectable text. A string consisting solely of hyphens is displayed
as a solid horizontal line.
A menu item can be a list with the same format as MENU. This is a submenu."
- (declare (indent defun))
+ (declare (indent defun) (debug (symbolp body)))
`(progn
,(if symbol `(defvar ,symbol nil ,doc))
(easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 7fcd339d6d..d656dcf952 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1,4 +1,4 @@
-;;; edebug.el --- a source-level debugger for Emacs Lisp
+;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1988-1995, 1997, 1999-2012 Free Software Foundation, Inc.
@@ -52,10 +52,7 @@
;;; Code:
(require 'macroexp)
-
-;;; Bug reporting
-
-(defalias 'edebug-submit-bug-report 'report-emacs-bug)
+(eval-when-compile (require 'cl-lib))
;;; Options
@@ -235,14 +232,9 @@ If the result is non-nil, then break. Errors are ignored."
;;; Form spec utilities.
-(defmacro def-edebug-form-spec (symbol spec-form)
- "For compatibility with old version."
- (def-edebug-spec symbol (eval spec-form)))
-(make-obsolete 'def-edebug-form-spec 'def-edebug-spec "22.1")
-
(defun get-edebug-spec (symbol)
;; Get the spec of symbol resolving all indirection.
- (let ((edebug-form-spec nil)
+ (let ((spec nil)
(indirect symbol))
(while
(progn
@@ -250,9 +242,8 @@ If the result is non-nil, then break. Errors are ignored."
(setq indirect
(function-get indirect 'edebug-form-spec 'macro))))
;; (edebug-trace "indirection: %s" edebug-form-spec)
- (setq edebug-form-spec indirect))
- edebug-form-spec
- ))
+ (setq spec indirect))
+ spec))
;;;###autoload
(defun edebug-basic-spec (spec)
@@ -342,9 +333,7 @@ A lambda list keyword is a symbol that starts with `&'."
(lambda (e1 e2)
(funcall function (car e1) (car e2))))))
-;;(def-edebug-spec edebug-save-restriction t)
-
-;; Not used. If it is used, def-edebug-spec must be defined before use.
+;; Not used.
'(defmacro edebug-save-restriction (&rest body)
"Evaluate BODY while saving the current buffers restriction.
BODY may change buffer outside of current restriction, unlike
@@ -352,6 +341,7 @@ save-restriction. BODY may change the current buffer,
and the restriction will be restored to the original buffer,
and the current buffer remains current.
Return the result of the last expression in BODY."
+ (declare (debug t))
`(let ((edebug:s-r-beg (point-min-marker))
(edebug:s-r-end (point-max-marker)))
(unwind-protect
@@ -369,6 +359,7 @@ Return the result of the last expression in BODY."
;; Select WINDOW if it is provided and still exists. Otherwise,
;; if buffer is currently shown in several windows, choose one.
;; Otherwise, find a new window, possibly splitting one.
+ ;; FIXME: We should probably just be using `pop-to-buffer'.
(setq window
(cond
((and (edebug-window-live-p window)
@@ -377,7 +368,7 @@ Return the result of the last expression in BODY."
((eq (window-buffer (selected-window)) buffer)
;; Selected window already displays BUFFER.
(selected-window))
- ((edebug-get-buffer-window buffer))
+ ((get-buffer-window buffer 0))
((one-window-p 'nomini)
;; When there's one window only, split it.
(split-window))
@@ -450,18 +441,14 @@ Return the result of the last expression in BODY."
window-info)
(set-window-configuration window-info)))
-(defalias 'edebug-get-buffer-window 'get-buffer-window)
-(defalias 'edebug-sit-for 'sit-for)
-(defalias 'edebug-input-pending-p 'input-pending-p)
-
-
;;; Redefine read and eval functions
;; read is redefined to maybe instrument forms.
;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs.
;; Save the original read function
-(or (fboundp 'edebug-original-read)
- (defalias 'edebug-original-read (symbol-function 'read)))
+(defalias 'edebug-original-read
+ (symbol-function (if (fboundp 'edebug-original-read)
+ 'edebug-original-read 'read)))
(defun edebug-read (&optional stream)
"Read one Lisp expression as text from STREAM, return as Lisp object.
@@ -626,36 +613,29 @@ already is one.)"
;; The internal data that is needed for edebugging is kept in the
;; buffer-local variable `edebug-form-data'.
-(make-variable-buffer-local 'edebug-form-data)
-
-(defvar edebug-form-data nil)
-;; A list of entries associating symbols with buffer regions.
-;; This is an automatic buffer local variable. Each entry looks like:
-;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers
-;; are at the beginning and end of an entry level form and @var{symbol} is
-;; a symbol that holds all edebug related information for the form on its
-;; property list.
-
-;; In the future, the symbol will be irrelevant and edebug data will
-;; be stored in the definitions themselves rather than in the property
-;; list of a symbol.
-
-(defun edebug-make-form-data-entry (symbol begin end)
- (list symbol begin end))
-
-(defsubst edebug-form-data-name (entry)
- (car entry))
-
-(defsubst edebug-form-data-begin (entry)
- (nth 1 entry))
-
-(defsubst edebug-form-data-end (entry)
- (nth 2 entry))
+(defvar-local edebug-form-data nil
+ "A list of entries associating symbols with buffer regions.
+Each entry is an `edebug--form-data' struct with fields:
+SYMBOL, BEGIN-MARKER, and END-MARKER. The markers
+are at the beginning and end of an entry level form and SYMBOL is
+a symbol that holds all edebug related information for the form on its
+property list.
+
+In the future (haha!), the symbol will be irrelevant and edebug data will
+be stored in the definitions themselves rather than in the property
+list of a symbol.")
+
+(cl-defstruct (edebug--form-data
+ ;; Some callers expect accessors to return nil when passed nil.
+ (:type list)
+ (:constructor edebug--make-form-data-entry (name begin end))
+ (:predicate nil) (:constructor nil) (:copier nil))
+ name begin end)
(defsubst edebug-set-form-data-entry (entry name begin end)
- (setcar entry name);; in case name is changed
- (set-marker (nth 1 entry) begin)
- (set-marker (nth 2 entry) end))
+ (setf (edebug--form-data-name entry) name) ;; In case name is changed.
+ (set-marker (edebug--form-data-begin entry) begin)
+ (set-marker (edebug--form-data-end entry) end))
(defun edebug-get-form-data-entry (pnt &optional end-point)
;; Find the edebug form data entry which is closest to PNT.
@@ -663,17 +643,17 @@ already is one.)"
;; Return `nil' if none found.
(let ((rest edebug-form-data)
closest-entry
- (closest-dist 999999)) ;; need maxint here
+ (closest-dist 999999)) ;; Need maxint here.
(while (and rest (< 0 closest-dist))
(let* ((entry (car rest))
- (begin (edebug-form-data-begin entry))
+ (begin (edebug--form-data-begin entry))
(dist (- pnt begin)))
(setq rest (cdr rest))
(if (and (<= 0 dist)
(< dist closest-dist)
(or (not end-point)
- (= end-point (edebug-form-data-end entry)))
- (<= pnt (edebug-form-data-end entry)))
+ (= end-point (edebug--form-data-end entry)))
+ (<= pnt (edebug--form-data-end entry)))
(setq closest-dist dist
closest-entry entry))))
closest-entry))
@@ -682,19 +662,19 @@ already is one.)"
;; and find an entry given a symbol, which should be just assq.
(defun edebug-form-data-symbol ()
-;; Return the edebug data symbol of the form where point is in.
-;; If point is not inside a edebuggable form, cause error.
- (or (edebug-form-data-name (edebug-get-form-data-entry (point)))
+ "Return the edebug data symbol of the form where point is in.
+If point is not inside a edebuggable form, cause error."
+ (or (edebug--form-data-name (edebug-get-form-data-entry (point)))
(error "Not inside instrumented form")))
(defun edebug-make-top-form-data-entry (new-entry)
;; Make NEW-ENTRY the first element in the `edebug-form-data' list.
(edebug-clear-form-data-entry new-entry)
- (setq edebug-form-data (cons new-entry edebug-form-data)))
+ (push new-entry edebug-form-data))
(defun edebug-clear-form-data-entry (entry)
-;; If non-nil, clear ENTRY out of the form data.
-;; Maybe clear the markers and delete the symbol's edebug property?
+ "If non-nil, clear ENTRY out of the form data.
+Maybe clear the markers and delete the symbol's edebug property?"
(if entry
(progn
;; Instead of this, we could just find all contained forms.
@@ -1086,7 +1066,8 @@ already is one.)"
;; If it gets an error, make it nil.
(let ((temp-hook edebug-setup-hook))
(setq edebug-setup-hook nil)
- (run-hooks 'temp-hook))
+ (if (functionp temp-hook) (funcall temp-hook)
+ (mapc #'funcall temp-hook)))
(let (result
edebug-top-window-data
@@ -1223,8 +1204,8 @@ already is one.)"
(defvar edebug-offset-list) ; the list of offset positions.
(defun edebug-inc-offset (offset)
- ;; modifies edebug-offset-index and edebug-offset-list
- ;; accesses edebug-func-marc and buffer point
+ ;; Modifies edebug-offset-index and edebug-offset-list
+ ;; accesses edebug-func-marc and buffer point.
(prog1
edebug-offset-index
(setq edebug-offset-list (cons (- offset edebug-form-begin-marker)
@@ -1237,13 +1218,11 @@ already is one.)"
;; given FORM. Looks like:
;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM)
;; Also increment the offset index for subsequent use.
- (list 'edebug-after
- (list 'edebug-before before-index)
- after-index form))
+ `(edebug-after (edebug-before ,before-index) ,after-index ,form))
(defun edebug-make-after-form (form after-index)
;; Like edebug-make-before-and-after-form, but only after.
- (list 'edebug-after 0 after-index form))
+ `(edebug-after 0 ,after-index ,form))
(defun edebug-unwrap (sexp)
@@ -1293,7 +1272,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;; Set this marker before parsing.
(edebug-form-begin-marker
(if form-data-entry
- (edebug-form-data-begin form-data-entry)
+ (edebug--form-data-begin form-data-entry)
;; Buffer must be current-buffer for this to work:
(set-marker (make-marker) form-begin))))
@@ -1303,7 +1282,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;; For definitions.
;; (edebug-containing-def-name edebug-def-name)
;; Get name from form-data, if any.
- (edebug-old-def-name (edebug-form-data-name form-data-entry))
+ (edebug-old-def-name (edebug--form-data-name form-data-entry))
edebug-def-name
edebug-def-args
edebug-def-interactive
@@ -1333,7 +1312,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;; In the latter case, pointers to the entry remain eq.
(if (not form-data-entry)
(setq form-data-entry
- (edebug-make-form-data-entry
+ (edebug--make-form-data-entry
edebug-def-name
edebug-form-begin-marker
;; Buffer must be current-buffer.
@@ -1519,18 +1498,18 @@ expressions; a `progn' form will be returned enclosing these forms."
;; Otherwise it signals an error. The place of the error is found
;; with the two before- and after-offset functions.
-(defun edebug-no-match (cursor &rest edebug-args)
+(defun edebug-no-match (cursor &rest args)
;; Throw a no-match, or signal an error immediately if gate is active.
;; Remember this point in case we need to report this error.
(setq edebug-error-point (or edebug-error-point
(edebug-before-offset cursor))
- edebug-best-error (or edebug-best-error edebug-args))
+ edebug-best-error (or edebug-best-error args))
(if (and edebug-gate (not edebug-&optional))
(progn
(if edebug-error-point
(goto-char edebug-error-point))
- (apply 'edebug-syntax-error edebug-args))
- (funcall 'throw 'no-match edebug-args)))
+ (apply 'edebug-syntax-error args))
+ (throw 'no-match args)))
(defun edebug-match (cursor specs)
@@ -1757,7 +1736,7 @@ expressions; a `progn' form will be returned enclosing these forms."
specs))))
-(defun edebug-match-gate (cursor)
+(defun edebug-match-gate (_cursor)
;; Simply set the gate to prevent backtracking at this level.
(setq edebug-gate t)
nil)
@@ -1846,7 +1825,7 @@ expressions; a `progn' form will be returned enclosing these forms."
nil))
-(defun edebug-match-function (cursor)
+(defun edebug-match-function (_cursor)
(error "Use function-form instead of function in edebug spec"))
(defun edebug-match-&define (cursor specs)
@@ -1903,7 +1882,7 @@ expressions; a `progn' form will be returned enclosing these forms."
(edebug-move-cursor cursor)
(list name)))
-(defun edebug-match-colon-name (cursor spec)
+(defun edebug-match-colon-name (_cursor spec)
;; Set the edebug-def-name to the spec.
(setq edebug-def-name
(if edebug-def-name
@@ -1988,6 +1967,8 @@ expressions; a `progn' form will be returned enclosing these forms."
def-body))
;; FIXME? Isn't this missing the doc-string? Cf defun.
(def-edebug-spec defmacro
+ ;; FIXME: Improve `declare' so we can Edebug gv-expander and
+ ;; gv-setter declarations.
(&define name lambda-list [&optional ("declare" &rest sexp)] def-body))
(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list.
@@ -2018,11 +1999,6 @@ expressions; a `progn' form will be returned enclosing these forms."
;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro])))
;; Standard functions that take function-forms arguments.
-(def-edebug-spec mapcar (function-form form))
-(def-edebug-spec mapconcat (function-form form form))
-(def-edebug-spec mapatoms (function-form &optional form))
-(def-edebug-spec apply (function-form &rest form))
-(def-edebug-spec funcall (function-form &rest form))
;; FIXME? The manual uses this form (maybe that's just for illustration?):
;; (def-edebug-spec let
@@ -2088,49 +2064,12 @@ expressions; a `progn' form will be returned enclosing these forms."
&or ("quote" edebug-\`) def-form))
;; New byte compiler.
-(def-edebug-spec defsubst defun)
-(def-edebug-spec dont-compile t)
-(def-edebug-spec eval-when-compile t)
-(def-edebug-spec eval-and-compile t)
(def-edebug-spec save-selected-window t)
(def-edebug-spec save-current-buffer t)
-(def-edebug-spec delay-mode-hooks t)
-(def-edebug-spec with-temp-file t)
-(def-edebug-spec with-temp-message t)
-(def-edebug-spec with-syntax-table t)
-(def-edebug-spec push (form sexp))
-(def-edebug-spec pop (sexp))
-
-(def-edebug-spec 1value (form))
-(def-edebug-spec noreturn (form))
-
;; Anything else?
-
-;; Some miscellaneous specs for macros in public packages.
-;; Send me yours.
-
-;; advice.el by Hans Chalupsky ([email protected])
-
-(def-edebug-spec ad-dolist ((symbolp form &optional form) body))
-(def-edebug-spec defadvice
- (&define name ;; thing being advised.
- (name ;; class is [&or "before" "around" "after"
- ;; "activation" "deactivation"]
- name ;; name of advice
- &rest sexp ;; optional position and flags
- )
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body))
-
-(def-edebug-spec easy-menu-define (symbolp body))
-
-(def-edebug-spec with-custom-print body)
-
-
;;; The debugger itself
(defvar edebug-active nil) ;; Non-nil when edebug is active
@@ -2167,10 +2106,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;; Dynamically bound variables, declared globally but left unbound.
(defvar edebug-function) ; the function being executed. change name!!
-(defvar edebug-args) ; the arguments of the function
(defvar edebug-data) ; the edebug data for the function
-(defvar edebug-value) ; the result of the expression
-(defvar edebug-after-index)
(defvar edebug-def-mark) ; the mark for the definition
(defvar edebug-freq-count) ; the count of expression visits.
(defvar edebug-coverage) ; the coverage results of each expression of function.
@@ -2186,8 +2122,6 @@ expressions; a `progn' form will be returned enclosing these forms."
(defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside
(defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside
-(defvar edebug-outside-overriding-local-map)
-(defvar edebug-outside-overriding-terminal-local-map)
(defvar edebug-outside-pre-command-hook)
(defvar edebug-outside-post-command-hook)
@@ -2196,7 +2130,7 @@ expressions; a `progn' form will be returned enclosing these forms."
;;; Handling signals
-(defun edebug-signal (edebug-signal-name edebug-signal-data)
+(defun edebug-signal (signal-name signal-data)
"Signal an error. Args are SIGNAL-NAME, and associated DATA.
A signal name is a symbol with an `error-conditions' property
that is a list of condition names.
@@ -2210,19 +2144,18 @@ See `condition-case'.
This is the Edebug replacement for the standard `signal'. It should
only be active while Edebug is. It checks `debug-on-error' to see
whether it should call the debugger. When execution is resumed, the
-error is signaled again.
-\n(fn SIGNAL-NAME DATA)"
- (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error))
- (edebug 'error (cons edebug-signal-name edebug-signal-data)))
+error is signaled again."
+ (if (and (listp debug-on-error) (memq signal-name debug-on-error))
+ (edebug 'error (cons signal-name signal-data)))
;; If we reach here without another non-local exit, then send signal again.
;; i.e. the signal is not continuable, yet.
;; Avoid infinite recursion.
(let ((signal-hook-function nil))
- (signal edebug-signal-name edebug-signal-data)))
+ (signal signal-name signal-data)))
;;; Entering Edebug
-(defun edebug-enter (edebug-function edebug-args edebug-body)
+(defun edebug-enter (function args body)
;; Entering FUNC. The arguments are ARGS, and the body is BODY.
;; Setup edebug variables and evaluate BODY. This function is called
;; when a function evaluated with edebug-eval-top-level-form is entered.
@@ -2231,83 +2164,51 @@ error is signaled again.
;; Is this the first time we are entering edebug since
;; lower-level recursive-edit command?
;; More precisely, this tests whether Edebug is currently active.
- (if (not edebug-entered)
- (let ((edebug-entered t)
- ;; Binding max-lisp-eval-depth here is OK,
- ;; but not inside an unwind-protect.
- ;; Doing it here also keeps it from growing too large.
- (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much??
- (max-specpdl-size (+ 200 max-specpdl-size))
-
- (debugger edebug-debugger) ; only while edebug is active.
- (edebug-outside-debug-on-error debug-on-error)
- (edebug-outside-debug-on-quit debug-on-quit)
- ;; Binding these may not be the right thing to do.
- ;; We want to allow the global values to be changed.
- (debug-on-error (or debug-on-error edebug-on-error))
- (debug-on-quit edebug-on-quit)
-
- ;; Lexical bindings must be uncompiled for this to work.
- (cl-lexical-debug t)
-
- (edebug-outside-overriding-local-map overriding-local-map)
- (edebug-outside-overriding-terminal-local-map
- overriding-terminal-local-map)
-
- ;; Save the outside value of executing macro. (here??)
- (edebug-outside-executing-macro executing-kbd-macro)
- (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
- ;; non-nil. Again, local binding may not be best.
- (executing-kbd-macro
- (if edebug-continue-kbd-macro executing-kbd-macro))
-
- ;; Don't get confused by the user's keymap changes.
- (overriding-local-map nil)
- (overriding-terminal-local-map nil)
-
- (signal-hook-function 'edebug-signal)
-
- ;; Disable command hooks. This is essential when
- ;; a hook function is instrumented - to avoid infinite loop.
- ;; This may be more than we need, however.
- (pre-command-hook nil)
- (post-command-hook nil))
- (setq edebug-execution-mode (or edebug-next-execution-mode
- edebug-initial-mode
- edebug-execution-mode)
- 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)
- (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
- (edebug-freq-count (get edebug-function 'edebug-freq-count))
- (edebug-coverage (get edebug-function 'edebug-coverage))
- (edebug-buffer (marker-buffer edebug-def-mark))
-
- (edebug-stack (cons edebug-function edebug-stack))
- (edebug-offset-indices (cons 0 edebug-offset-indices))
- )
- (if (get edebug-function 'edebug-on-entry)
- (progn
- (setq edebug-execution-mode 'step)
- (if (eq (get edebug-function 'edebug-on-entry) 'temp)
- (put edebug-function 'edebug-on-entry nil))))
- (if edebug-trace
- (edebug-enter-trace edebug-body)
- (funcall edebug-body))
- )))
+ (let ((edebug-function function))
+ (if (not edebug-entered)
+ (let ((edebug-entered t)
+ ;; Binding max-lisp-eval-depth here is OK,
+ ;; but not inside an unwind-protect.
+ ;; Doing it here also keeps it from growing too large.
+ (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much??
+ (max-specpdl-size (+ 200 max-specpdl-size))
+
+ (debugger edebug-debugger) ; only while edebug is active.
+ (edebug-outside-debug-on-error debug-on-error)
+ (edebug-outside-debug-on-quit debug-on-quit)
+ ;; Binding these may not be the right thing to do.
+ ;; We want to allow the global values to be changed.
+ (debug-on-error (or debug-on-error edebug-on-error))
+ (debug-on-quit edebug-on-quit)
+
+ ;; Lexical bindings must be uncompiled for this to work.
+ (cl-lexical-debug t))
+ (unwind-protect
+ (let ((signal-hook-function 'edebug-signal))
+ (setq edebug-execution-mode (or edebug-next-execution-mode
+ edebug-initial-mode
+ edebug-execution-mode)
+ edebug-next-execution-mode nil)
+ (edebug-enter function args body))))
+
+ (let* ((edebug-data (get function 'edebug))
+ (edebug-def-mark (car edebug-data)) ; mark at def start
+ (edebug-freq-count (get function 'edebug-freq-count))
+ (edebug-coverage (get function 'edebug-coverage))
+ (edebug-buffer (marker-buffer edebug-def-mark))
+
+ (edebug-stack (cons function edebug-stack))
+ (edebug-offset-indices (cons 0 edebug-offset-indices))
+ )
+ (if (get function 'edebug-on-entry)
+ (progn
+ (setq edebug-execution-mode 'step)
+ (if (eq (get function 'edebug-on-entry) 'temp)
+ (put function 'edebug-on-entry nil))))
+ (if edebug-trace
+ (edebug--enter-trace function args body)
+ (funcall body))
+ ))))
(defun edebug-var-status (var)
"Return a cons cell describing the status of VAR's current binding.
@@ -2334,14 +2235,14 @@ STATUS should be a list returned by `edebug-var-status'."
(t
(set var value)))))
-(defun edebug-enter-trace (edebug-body)
+(defun edebug--enter-trace (function args body)
(let ((edebug-stack-depth (1+ edebug-stack-depth))
edebug-result)
(edebug-print-trace-before
- (format "%s args: %s" edebug-function edebug-args))
- (prog1 (setq edebug-result (funcall edebug-body))
+ (format "%s args: %s" function args))
+ (prog1 (setq edebug-result (funcall body))
(edebug-print-trace-after
- (format "%s result: %s" edebug-function edebug-result)))))
+ (format "%s result: %s" function edebug-result)))))
(def-edebug-spec edebug-tracing (form body))
@@ -2369,49 +2270,49 @@ MSG is printed after `::::} '."
-(defun edebug-slow-before (edebug-before-index)
+(defun edebug-slow-before (before-index)
(unless edebug-active
;; Debug current function given BEFORE position.
;; Called from functions compiled with edebug-eval-top-level-form.
;; Return the before index.
- (setcar edebug-offset-indices edebug-before-index)
+ (setcar edebug-offset-indices before-index)
;; Increment frequency count
- (aset edebug-freq-count edebug-before-index
- (1+ (aref edebug-freq-count edebug-before-index)))
+ (aset edebug-freq-count before-index
+ (1+ (aref edebug-freq-count before-index)))
(if (or (not (memq edebug-execution-mode '(Go-nonstop next)))
- (edebug-input-pending-p))
- (edebug-debugger edebug-before-index 'before nil)))
- edebug-before-index)
+ (input-pending-p))
+ (edebug-debugger before-index 'before nil)))
+ before-index)
-(defun edebug-fast-before (edebug-before-index)
+(defun edebug-fast-before (_before-index)
;; Do nothing.
)
-(defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value)
+(defun edebug-slow-after (_before-index after-index value)
(if edebug-active
- edebug-value
+ value
;; Debug current function given AFTER position and VALUE.
;; Called from functions compiled with edebug-eval-top-level-form.
;; Return VALUE.
- (setcar edebug-offset-indices edebug-after-index)
+ (setcar edebug-offset-indices after-index)
;; Increment frequency count
- (aset edebug-freq-count edebug-after-index
- (1+ (aref edebug-freq-count edebug-after-index)))
- (if edebug-test-coverage (edebug-update-coverage))
+ (aset edebug-freq-count after-index
+ (1+ (aref edebug-freq-count after-index)))
+ (if edebug-test-coverage (edebug--update-coverage after-index value))
(if (and (eq edebug-execution-mode 'Go-nonstop)
- (not (edebug-input-pending-p)))
+ (not (input-pending-p)))
;; Just return result.
- edebug-value
- (edebug-debugger edebug-after-index 'after edebug-value)
+ value
+ (edebug-debugger after-index 'after value)
)))
-(defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value)
+(defun edebug-fast-after (_before-index _after-index value)
;; Do nothing but return the value.
- edebug-value)
+ value)
(defun edebug-run-slow ()
(defalias 'edebug-before 'edebug-slow-before)
@@ -2425,19 +2326,18 @@ MSG is printed after `::::} '."
(edebug-run-slow)
-(defun edebug-update-coverage ()
- (let ((old-result (aref edebug-coverage edebug-after-index)))
+(defun edebug--update-coverage (after-index value)
+ (let ((old-result (aref edebug-coverage after-index)))
(cond
((eq 'ok-coverage old-result))
((eq 'unknown old-result)
- (aset edebug-coverage edebug-after-index edebug-value))
+ (aset edebug-coverage after-index value))
;; Test if a different result.
- ((not (eq edebug-value old-result))
- (aset edebug-coverage edebug-after-index 'ok-coverage)))))
+ ((not (eq value old-result))
+ (aset edebug-coverage after-index 'ok-coverage)))))
;; Dynamically declared unbound variables.
-(defvar edebug-arg-mode) ; the mode, either before, after, or error
(defvar edebug-breakpoints)
(defvar edebug-break-data) ; break data for current function.
(defvar edebug-break) ; whether a break occurred.
@@ -2448,16 +2348,16 @@ MSG is printed after `::::} '."
(defvar edebug-global-break-result nil)
-(defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value)
+(defun edebug-debugger (offset-index arg-mode value)
(if inhibit-redisplay
;; Don't really try to enter edebug within an eval from redisplay.
- edebug-value
+ value
;; Check breakpoints and pending input.
- ;; If edebug display should be updated, call edebug-display.
- ;; Return edebug-value.
+ ;; If edebug display should be updated, call edebug--display.
+ ;; Return value.
(let* ( ;; This needs to be here since breakpoints may be changed.
(edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints
- (edebug-break-data (assq edebug-offset-index edebug-breakpoints))
+ (edebug-break-data (assq offset-index edebug-breakpoints))
(edebug-break-condition (car (cdr edebug-break-data)))
(edebug-global-break
(if edebug-global-break-condition
@@ -2468,7 +2368,7 @@ MSG is printed after `::::} '."
(error nil))))
(edebug-break))
-;;; (edebug-trace "exp: %s" edebug-value)
+ ;;(edebug-trace "exp: %s" value)
;; Test whether we should break.
(setq edebug-break
(or edebug-global-break
@@ -2488,11 +2388,10 @@ MSG is printed after `::::} '."
;; or break, or input is pending,
(if (or (not (memq edebug-execution-mode '(go continue Continue-fast)))
edebug-break
- (edebug-input-pending-p))
- (edebug-display)) ; <--------------- display
+ (input-pending-p))
+ (edebug--display value offset-index arg-mode)) ; <---------- display
- edebug-value
- )))
+ value)))
;; window-start now stored with each function.
@@ -2524,8 +2423,9 @@ MSG is printed after `::::} '."
;; Emacs 19 adds an arg to mark and mark-marker.
(defalias 'edebug-mark-marker 'mark-marker)
+(defvar edebug-outside-unread-command-events)
-(defun edebug-display ()
+(defun edebug--display (value offset-index arg-mode)
(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
@@ -2534,11 +2434,11 @@ MSG is printed after `::::} '."
;; Setup windows for edebug, determine mode, maybe enter recursive-edit.
;; Uses local variables of edebug-enter, edebug-before, edebug-after
;; and edebug-debugger.
- (let ((edebug-active t) ; for minor mode alist
+ (let ((edebug-active t) ; For minor mode alist.
(edebug-with-timeout-suspend (with-timeout-suspend))
- edebug-stop ; should we enter recursive-edit
+ edebug-stop ; Should we enter recursive-edit?
(edebug-point (+ edebug-def-mark
- (aref (nth 2 edebug-data) edebug-offset-index)))
+ (aref (nth 2 edebug-data) offset-index)))
edebug-buffer-outside-point ; current point in edebug-buffer
;; window displaying edebug-buffer
(edebug-window-data (nth 3 edebug-data))
@@ -2547,12 +2447,12 @@ MSG is printed after `::::} '."
(edebug-outside-point (point))
(edebug-outside-mark (edebug-mark))
(edebug-outside-unread-command-events unread-command-events)
- edebug-outside-windows ; window or screen configuration
+ edebug-outside-windows ; Window or screen configuration.
edebug-buffer-points
- edebug-eval-buffer ; declared here so we can kill it below
- (edebug-eval-result-list (and edebug-eval-list
- (edebug-eval-result-list)))
+ edebug-eval-buffer ; Declared here so we can kill it below.
+ (eval-result-list (and edebug-eval-list
+ (edebug-eval-result-list)))
edebug-trace-window
edebug-trace-window-start
@@ -2565,7 +2465,7 @@ MSG is printed after `::::} '."
(let ((overlay-arrow-position overlay-arrow-position)
(overlay-arrow-string overlay-arrow-string)
(cursor-in-echo-area nil)
- (unread-command-events unread-command-events)
+ (unread-command-events nil)
;; any others??
)
(setq-default cursor-in-non-selected-windows t)
@@ -2573,9 +2473,9 @@ MSG is printed after `::::} '."
(let ((debug-on-error nil))
(error "Buffer defining %s not found" edebug-function)))
- (if (eq 'after edebug-arg-mode)
+ (if (eq 'after arg-mode)
;; Compute result string now before windows are modified.
- (edebug-compute-previous-result edebug-value))
+ (edebug-compute-previous-result value))
(if edebug-save-windows
;; Save windows now before we modify them.
@@ -2599,7 +2499,7 @@ MSG is printed after `::::} '."
;; Now display eval list, if any.
;; This is done after the pop to edebug-buffer
;; so that buffer-window correspondence is correct after quitting.
- (edebug-eval-display edebug-eval-result-list)
+ (edebug-eval-display eval-result-list)
;; The evaluation list better not have deleted edebug-window-data.
(select-window (car edebug-window-data))
(set-buffer edebug-buffer)
@@ -2607,7 +2507,7 @@ MSG is printed after `::::} '."
(setq edebug-buffer-outside-point (point))
(goto-char edebug-point)
- (if (eq 'before edebug-arg-mode)
+ (if (eq 'before arg-mode)
;; Check whether positions are up-to-date.
;; This assumes point is never before symbol.
(if (not (memq (following-char) '(?\( ?\# ?\` )))
@@ -2620,7 +2520,7 @@ MSG is printed after `::::} '."
(edebug-adjust-window (cdr edebug-window-data)))
;; Test if there is input, not including keyboard macros.
- (if (edebug-input-pending-p)
+ (if (input-pending-p)
(progn
(setq edebug-execution-mode 'step
edebug-stop t)
@@ -2631,14 +2531,14 @@ MSG is printed after `::::} '."
(edebug-overlay-arrow)
(cond
- ((eq 'error edebug-arg-mode)
+ ((eq 'error arg-mode)
;; Display error message
(setq edebug-execution-mode 'step)
(edebug-overlay-arrow)
(beep)
- (if (eq 'quit (car edebug-value))
+ (if (eq 'quit (car value))
(message "Quit")
- (edebug-report-error edebug-value)))
+ (edebug-report-error value)))
(edebug-break
(cond
(edebug-global-break
@@ -2655,41 +2555,40 @@ MSG is printed after `::::} '."
(t (message "")))
- (setq unread-command-events nil)
- (if (eq 'after edebug-arg-mode)
+ (if (eq 'after arg-mode)
(progn
;; Display result of previous evaluation.
(if (and edebug-break
(not (eq edebug-execution-mode 'Continue-fast)))
- (edebug-sit-for edebug-sit-for-seconds)) ; Show message.
+ (sit-for edebug-sit-for-seconds)) ; Show message.
(edebug-previous-result)))
(cond
(edebug-break
(cond
((eq edebug-execution-mode 'continue)
- (edebug-sit-for edebug-sit-for-seconds))
- ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0))
+ (sit-for edebug-sit-for-seconds))
+ ((eq edebug-execution-mode 'Continue-fast) (sit-for 0))
(t (setq edebug-stop t))))
;; not edebug-break
((eq edebug-execution-mode 'trace)
- (edebug-sit-for edebug-sit-for-seconds)) ; Force update and pause.
+ (sit-for edebug-sit-for-seconds)) ; Force update and pause.
((eq edebug-execution-mode 'Trace-fast)
- (edebug-sit-for 0))) ; Force update and continue.
+ (sit-for 0))) ; Force update and continue.
(unwind-protect
(if (or edebug-stop
(memq edebug-execution-mode '(step next))
- (eq edebug-arg-mode 'error))
+ (eq arg-mode 'error))
(progn
;; (setq edebug-execution-mode 'step)
;; (edebug-overlay-arrow) ; This doesn't always show up.
- (edebug-recursive-edit))) ; <---------- Recursive edit
+ (edebug--recursive-edit arg-mode))) ; <----- Recursive edit
;; Reset the edebug-window-data to whatever it is now.
(let ((window (if (eq (window-buffer) edebug-buffer)
(selected-window)
- (edebug-get-buffer-window edebug-buffer))))
+ (get-buffer-window edebug-buffer))))
;; Remember window-start for edebug-buffer, if still displayed.
(if window
(progn
@@ -2767,6 +2666,8 @@ MSG is printed after `::::} '."
(goto-char edebug-buffer-outside-point))
;; ... nothing more.
)
+ ;; Could be an option to keep eval display up.
+ (if edebug-eval-buffer (kill-buffer edebug-eval-buffer))
(with-timeout-unsuspend edebug-with-timeout-suspend)
;; Reset global variables to outside values in case they were changed.
(setq
@@ -2804,26 +2705,15 @@ MSG is printed after `::::} '."
;; in versions where the variable is *not* built-in.
;; Emacs 18 FIXME
-(defvar edebug-outside-unread-command-char)
;; Emacs 19.
(defvar edebug-outside-last-command-event)
-(defvar edebug-outside-unread-command-events)
(defvar edebug-outside-last-input-event)
(defvar edebug-outside-last-event-frame)
(defvar edebug-outside-last-nonmenu-event)
(defvar edebug-outside-track-mouse)
-;; Disable byte compiler warnings about unread-command-char and -event
-;; (maybe works with byte-compile-version 2.22 at least)
-(defvar edebug-unread-command-char-warning)
-(defvar edebug-unread-command-event-warning)
-(eval-when-compile ; FIXME
- (setq edebug-unread-command-char-warning
- (get 'unread-command-char 'byte-obsolete-variable))
- (put 'unread-command-char 'byte-obsolete-variable nil))
-
-(defun edebug-recursive-edit ()
+(defun edebug--recursive-edit (arg-mode)
;; Start up a recursive edit inside of edebug.
;; The current buffer is the edebug-buffer, which is put into edebug-mode.
;; Assume that none of the variables below are buffer-local.
@@ -2844,14 +2734,20 @@ MSG is printed after `::::} '."
(edebug-outside-map (current-local-map))
- (edebug-outside-standard-output standard-output)
+ ;; Save the outside value of executing macro. (here??)
+ (edebug-outside-executing-macro executing-kbd-macro)
+ (edebug-outside-pre-command-hook
+ (edebug-var-status 'pre-command-hook))
+ (edebug-outside-post-command-hook
+ (edebug-var-status 'post-command-hook))
+
+ (edebug-outside-standard-output standard-output)
(edebug-outside-standard-input standard-input)
(edebug-outside-defining-kbd-macro defining-kbd-macro)
(edebug-outside-last-command last-command)
(edebug-outside-this-command this-command)
- (edebug-outside-unread-command-char unread-command-char) ; FIXME
(edebug-outside-current-prefix-arg current-prefix-arg)
(edebug-outside-last-input-event last-input-event)
@@ -2867,9 +2763,6 @@ MSG is printed after `::::} '."
;; We could set these to the values for previous edebug call.
(last-command last-command)
(this-command this-command)
-
- ;; Assume no edebug command sets unread-command-char.
- (unread-command-char -1)
(current-prefix-arg nil)
;; More for Emacs 19
@@ -2879,7 +2772,20 @@ MSG is printed after `::::} '."
(last-nonmenu-event nil)
(track-mouse nil)
- ;; Bind again to outside values.
+ (standard-output t)
+ (standard-input t)
+
+ ;; Don't keep reading from an executing kbd macro
+ ;; within edebug unless edebug-continue-kbd-macro is
+ ;; non-nil. Again, local binding may not be best.
+ (executing-kbd-macro
+ (if edebug-continue-kbd-macro executing-kbd-macro))
+
+ ;; Don't get confused by the user's keymap changes.
+ (overriding-local-map nil)
+ (overriding-terminal-local-map nil)
+
+ ;; Bind again to outside values.
(debug-on-error edebug-outside-debug-on-error)
(debug-on-quit edebug-outside-debug-on-quit)
@@ -2887,11 +2793,17 @@ MSG is printed after `::::} '."
(defining-kbd-macro
(if edebug-continue-kbd-macro defining-kbd-macro))
+ ;; Disable command hooks. This is essential when
+ ;; a hook function is instrumented - to avoid infinite loop.
+ ;; This may be more than we need, however.
+ (pre-command-hook nil)
+ (post-command-hook nil)
+
;; others??
)
(if (and (eq edebug-execution-mode 'go)
- (not (memq edebug-arg-mode '(after error))))
+ (not (memq arg-mode '(after error))))
(message "Break"))
(setq buffer-read-only t)
@@ -2905,8 +2817,6 @@ MSG is printed after `::::} '."
(setq signal-hook-function 'edebug-signal)
(if edebug-backtrace-buffer
(kill-buffer edebug-backtrace-buffer))
- ;; Could be an option to keep eval display up.
- (if edebug-eval-buffer (kill-buffer edebug-eval-buffer))
;; Remember selected-window after recursive-edit.
;; (setq edebug-inside-window (selected-window))
@@ -2933,7 +2843,6 @@ MSG is printed after `::::} '."
last-command-event edebug-outside-last-command-event
last-command edebug-outside-last-command
this-command edebug-outside-this-command
- unread-command-char edebug-outside-unread-command-char
current-prefix-arg edebug-outside-current-prefix-arg
last-input-event edebug-outside-last-input-event
last-event-frame edebug-outside-last-event-frame
@@ -2942,17 +2851,21 @@ MSG is printed after `::::} '."
standard-output edebug-outside-standard-output
standard-input edebug-outside-standard-input
- defining-kbd-macro edebug-outside-defining-kbd-macro
- ))
- ))
+ defining-kbd-macro edebug-outside-defining-kbd-macro)
+
+ (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))))
;;; Display related functions
(defun edebug-adjust-window (old-start)
;; If pos is not visible, adjust current window to fit following context.
-;;; (message "window: %s old-start: %s window-start: %s pos: %s"
-;;; (selected-window) old-start (window-start) (point)) (sit-for 5)
+ ;; (message "window: %s old-start: %s window-start: %s pos: %s"
+ ;; (selected-window) old-start (window-start) (point)) (sit-for 5)
(if (not (pos-visible-in-window-p))
(progn
;; First try old-start
@@ -2960,7 +2873,7 @@ MSG is printed after `::::} '."
(set-window-start (selected-window) old-start))
(if (not (pos-visible-in-window-p))
(progn
-;; (message "resetting window start") (sit-for 2)
+ ;; (message "resetting window start") (sit-for 2)
(set-window-start
(selected-window)
(save-excursion
@@ -3099,12 +3012,12 @@ before returning. The default is one second."
(current-buffer) (point)
(if (marker-buffer (edebug-mark-marker))
(marker-position (edebug-mark-marker)) "<not set>"))
- (edebug-sit-for arg)
+ (sit-for arg)
(edebug-pop-to-buffer edebug-buffer (car edebug-window-data)))))
;; Joe Wells, here is a start at your idea of adding a buffer to the internal
-;; display list. Still need to use this list in edebug-display.
+;; display list. Still need to use this list in edebug--display.
'(defvar edebug-display-buffer-list nil
"List of buffers that edebug will display when it is active.")
@@ -3426,7 +3339,7 @@ function or macro is called, Edebug will be called there as well."
(save-excursion
(down-list 1)
(if (looking-at "\(")
- (edebug-form-data-name
+ (edebug--form-data-name
(edebug-get-form-data-entry (point)))
(edebug-original-read (current-buffer))))))
(edebug-instrument-function func))))
@@ -3539,11 +3452,10 @@ edebug-mode."
;;; Evaluation of expressions
-(def-edebug-spec edebug-outside-excursion t)
-
(defmacro edebug-outside-excursion (&rest body)
"Evaluate an expression list in the outside context.
Return the result of the last expression."
+ (declare (debug t))
`(save-excursion ; of current-buffer
(if edebug-save-windows
(progn
@@ -3562,7 +3474,6 @@ Return the result of the last expression."
(last-command-event edebug-outside-last-command-event)
(last-command edebug-outside-last-command)
(this-command edebug-outside-this-command)
- (unread-command-char edebug-outside-unread-command-char)
(unread-command-events edebug-outside-unread-command-events)
(current-prefix-arg edebug-outside-current-prefix-arg)
(last-input-event edebug-outside-last-input-event)
@@ -3578,7 +3489,7 @@ Return the result of the last expression."
(pre-command-hook (cdr edebug-outside-pre-command-hook))
(post-command-hook (cdr edebug-outside-post-command-hook))
- ;; See edebug-display
+ ;; See edebug-display.
(overlay-arrow-position edebug-outside-o-a-p)
(overlay-arrow-string edebug-outside-o-a-s)
(cursor-in-echo-area edebug-outside-c-i-e-a)
@@ -3602,7 +3513,6 @@ Return the result of the last expression."
edebug-outside-last-command-event last-command-event
edebug-outside-last-command last-command
edebug-outside-this-command this-command
- edebug-outside-unread-command-char unread-command-char
edebug-outside-unread-command-events unread-command-events
edebug-outside-current-prefix-arg current-prefix-arg
edebug-outside-last-input-event last-input-event
@@ -3633,18 +3543,19 @@ Return the result of the last expression."
(defvar cl-debug-env) ; defined in cl; non-nil when lexical env used.
-(defun edebug-eval (edebug-expr)
+(defun edebug-eval (expr)
;; Are there cl lexical variables active?
- (eval (if (bound-and-true-p cl-debug-env)
- (cl-macroexpand-all edebug-expr cl-debug-env)
- edebug-expr)
+ (eval (if (and (bound-and-true-p cl-debug-env)
+ (fboundp 'cl-macroexpand-all))
+ (cl-macroexpand-all expr cl-debug-env)
+ expr)
lexical-binding))
-(defun edebug-safe-eval (edebug-expr)
+(defun edebug-safe-eval (expr)
;; Evaluate EXPR safely.
;; If there is an error, a string is returned describing the error.
(condition-case edebug-err
- (edebug-eval edebug-expr)
+ (edebug-eval expr)
(error (edebug-format "%s: %s" ;; could
(get (car edebug-err) 'error-message)
(car (cdr edebug-err))))))
@@ -3652,17 +3563,17 @@ Return the result of the last expression."
;;; Printing
-(defun edebug-report-error (edebug-value)
+(defun edebug-report-error (value)
;; Print an error message like command level does.
;; This also prints the error name if it has no error-message.
(message "%s: %s"
- (or (get (car edebug-value) 'error-message)
- (format "peculiar error (%s)" (car edebug-value)))
+ (or (get (car value) 'error-message)
+ (format "peculiar error (%s)" (car value)))
(mapconcat (function (lambda (edebug-arg)
;; continuing after an error may
;; complain about edebug-arg. why??
(prin1-to-string edebug-arg)))
- (cdr edebug-value) ", ")))
+ (cdr value) ", ")))
(defvar print-readably) ; defined by lemacs
;; Alternatively, we could change the definition of
@@ -3678,14 +3589,14 @@ Return the result of the last expression."
(edebug-prin1-to-string value)
(error "#Apparently circular structure#"))))
-(defun edebug-compute-previous-result (edebug-previous-value)
+(defun edebug-compute-previous-result (previous-value)
(if edebug-unwrap-results
- (setq edebug-previous-value
- (edebug-unwrap* edebug-previous-value)))
+ (setq previous-value
+ (edebug-unwrap* previous-value)))
(setq edebug-previous-result
(concat "Result: "
- (edebug-safe-prin1-to-string edebug-previous-value)
- (eval-expression-print-format edebug-previous-value))))
+ (edebug-safe-prin1-to-string previous-value)
+ (eval-expression-print-format previous-value))))
(defun edebug-previous-result ()
"Print the previous result."
@@ -3700,7 +3611,7 @@ Return the result of the last expression."
(defalias 'edebug-format 'format)
(defalias 'edebug-message 'message)
-(defun edebug-eval-expression (edebug-expr)
+(defun edebug-eval-expression (expr)
"Evaluate an expression in the outside environment.
If interactive, prompt for the expression.
Print result in minibuffer."
@@ -3709,7 +3620,7 @@ Print result in minibuffer."
'read-expression-history)))
(princ
(edebug-outside-excursion
- (setq values (cons (edebug-eval edebug-expr) values))
+ (setq values (cons (edebug-eval expr) values))
(concat (edebug-safe-prin1-to-string (car values))
(eval-expression-print-format (car values))))))
@@ -3723,14 +3634,14 @@ Print value in minibuffer."
"Evaluate sexp before point in outside environment; insert value.
This prints the value into current buffer."
(interactive)
- (let* ((edebug-form (edebug-last-sexp))
- (edebug-result-string
+ (let* ((form (edebug-last-sexp))
+ (result-string
(edebug-outside-excursion
- (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form))))
+ (edebug-safe-prin1-to-string (edebug-safe-eval form))))
(standard-output (current-buffer)))
(princ "\n")
;; princ the string to get rid of quotes.
- (princ edebug-result-string)
+ (princ result-string)
(princ "\n")
))
@@ -3922,44 +3833,38 @@ Options:
(edebug-trace nil))
(mapcar 'edebug-safe-eval edebug-eval-list)))
-(defun edebug-eval-display-list (edebug-eval-result-list)
+(defun edebug-eval-display-list (eval-result-list)
;; Assumes edebug-eval-buffer exists.
- (let ((edebug-eval-list-temp edebug-eval-list)
- (standard-output edebug-eval-buffer)
+ (let ((standard-output edebug-eval-buffer)
(edebug-comment-line
(format ";%s\n" (make-string (- (window-width) 2) ?-))))
(set-buffer edebug-eval-buffer)
(erase-buffer)
- (while edebug-eval-list-temp
- (prin1 (car edebug-eval-list-temp)) (terpri)
- (prin1 (car edebug-eval-result-list)) (terpri)
- (princ edebug-comment-line)
- (setq edebug-eval-list-temp (cdr edebug-eval-list-temp))
- (setq edebug-eval-result-list (cdr edebug-eval-result-list)))
+ (dolist (exp edebug-eval-list)
+ (prin1 exp) (terpri)
+ (prin1 (pop eval-result-list)) (terpri)
+ (princ edebug-comment-line))
(edebug-pop-to-buffer edebug-eval-buffer)
))
(defun edebug-create-eval-buffer ()
- (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer)))
- (progn
- (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*")))
- (edebug-eval-mode))))
+ (unless (and edebug-eval-buffer (buffer-name edebug-eval-buffer))
+ (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*")))
+ (edebug-eval-mode)))
;; Should generalize this to be callable outside of edebug
;; with calls in user functions, e.g. (edebug-eval-display)
-(defun edebug-eval-display (edebug-eval-result-list)
- "Display expressions and evaluations in EDEBUG-EVAL-RESULT-LIST.
+(defun edebug-eval-display (eval-result-list)
+ "Display expressions and evaluations in EVAL-RESULT-LIST.
It modifies the context by popping up the eval display."
- (if edebug-eval-result-list
- (progn
- (edebug-create-eval-buffer)
- (edebug-eval-display-list edebug-eval-result-list)
- )))
+ (when eval-result-list
+ (edebug-create-eval-buffer)
+ (edebug-eval-display-list eval-result-list)))
(defun edebug-eval-redisplay ()
"Redisplay eval list in outside environment.
-May only be called from within `edebug-recursive-edit'."
+May only be called from within `edebug--recursive-edit'."
(edebug-create-eval-buffer)
(edebug-outside-excursion
(edebug-eval-display-list (edebug-eval-result-list))
@@ -3983,7 +3888,7 @@ May only be called from within `edebug-recursive-edit'."
(if (not (eobp))
(progn
(forward-sexp 1)
- (setq new-list (cons (edebug-last-sexp) new-list))))
+ (push (edebug-last-sexp) new-list)))
(while (re-search-forward "^;" nil t)
(forward-line 1)
@@ -3992,7 +3897,7 @@ May only be called from within `edebug-recursive-edit'."
(not (eobp)))
(progn
(forward-sexp 1)
- (setq new-list (cons (edebug-last-sexp) new-list)))))
+ (push (edebug-last-sexp) new-list))))
(setq edebug-eval-list (nreverse new-list))
(edebug-eval-redisplay)
@@ -4021,8 +3926,8 @@ May only be called from within `edebug-recursive-edit'."
(define-key map "\C-c\C-u" 'edebug-update-eval-list)
(define-key map "\C-x\C-e" 'edebug-eval-last-sexp)
(define-key map "\C-j" 'edebug-eval-print-last-sexp)
- map)
-"Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.")
+ map)
+ "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.")
(put 'edebug-eval-mode 'mode-class 'special)
@@ -4049,32 +3954,32 @@ Global commands prefixed by `global-edebug-prefix':
;; since they depend on the backtrace looking a certain way. But
;; edebug is not dependent on this, yet.
-(defun edebug (&optional edebug-arg-mode &rest debugger-args)
+(defun edebug (&optional arg-mode &rest args)
"Replacement for `debug'.
If we are running an edebugged function, show where we last were.
Otherwise call `debug' normally."
-;; (message "entered: %s depth: %s edebug-recursion-depth: %s"
-;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1)
+ ;;(message "entered: %s depth: %s edebug-recursion-depth: %s"
+ ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1)
(if (and edebug-entered ; anything active?
(eq (recursion-depth) edebug-recursion-depth))
(let (;; Where were we before the error occurred?
- (edebug-offset-index (car edebug-offset-indices))
- ;; Bind variables required by edebug-display
- (edebug-value (car debugger-args))
+ (offset-index (car edebug-offset-indices))
+ (value (car args))
+ ;; Bind variables required by edebug--display.
edebug-breakpoints
edebug-break-data
edebug-break-condition
edebug-global-break
- (edebug-break (null edebug-arg-mode)) ;; if called explicitly
+ (edebug-break (null arg-mode)) ;; If called explicitly.
)
- (edebug-display)
- (if (eq edebug-arg-mode 'error)
+ (edebug--display value offset-index arg-mode)
+ (if (eq arg-mode 'error)
nil
- edebug-value))
+ value))
;; Otherwise call debug normally.
;; Still need to remove extraneous edebug calls from stack.
- (apply 'debug edebug-arg-mode debugger-args)
+ (apply 'debug arg-mode args)
))
@@ -4085,7 +3990,7 @@ Otherwise call `debug' normally."
(null (buffer-name edebug-backtrace-buffer)))
(setq edebug-backtrace-buffer
(generate-new-buffer "*Backtrace*"))
- ;; else, could just display edebug-backtrace-buffer
+ ;; Else, could just display edebug-backtrace-buffer.
)
(with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer)
(setq edebug-backtrace-buffer standard-output)
@@ -4107,7 +4012,7 @@ Otherwise call `debug' normally."
(beginning-of-line)
(cond
((looking-at "^ \(edebug-after")
- ;; Previous lines may contain code, so just delete this line
+ ;; Previous lines may contain code, so just delete this line.
(setq last-ok-point (point))
(forward-line 1)
(delete-region last-ok-point (point)))
@@ -4125,15 +4030,15 @@ Otherwise call `debug' normally."
"In buffer BUF-NAME, display FMT and ARGS at the end and make it visible.
The buffer is created if it does not exist.
You must include newlines in FMT to break lines, but one newline is appended."
-;; e.g.
-;; (edebug-trace-display "*trace-point*"
-;; "saving: point = %s window-start = %s"
-;; (point) (window-start))
+ ;; e.g.
+ ;; (edebug-trace-display "*trace-point*"
+ ;; "saving: point = %s window-start = %s"
+ ;; (point) (window-start))
(let* ((oldbuf (current-buffer))
(selected-window (selected-window))
(buffer (get-buffer-create buf-name))
buf-window)
-;; (message "before pop-to-buffer") (sit-for 1)
+ ;; (message "before pop-to-buffer") (sit-for 1)
(edebug-pop-to-buffer buffer)
(setq truncate-lines t)
(setq buf-window (selected-window))
@@ -4143,8 +4048,8 @@ You must include newlines in FMT to break lines, but one newline is appended."
(vertical-motion (- 1 (window-height)))
(set-window-start buf-window (point))
(goto-char (point-max))
-;; (set-window-point buf-window (point))
-;; (edebug-sit-for 0)
+ ;; (set-window-point buf-window (point))
+ ;; (sit-for 0)
(bury-buffer buffer)
(select-window selected-window)
(set-buffer oldbuf))
@@ -4207,8 +4112,8 @@ reinstrument it."
;; Insert all the indices for this line.
(forward-line 1)
(setq start-of-count-line (point)
- first-index i ; really last index for line above this one.
- last-count -1) ; cause first count to always appear.
+ first-index i ; Really, last index for line above this one.
+ last-count -1) ; Cause first count to always appear.
(insert ";#")
;; i == first-index still
(while (<= (setq i (1+ i)) last-index)
@@ -4240,7 +4145,8 @@ It is removed when you hit any char."
(let ((buffer-read-only nil))
(undo-boundary)
(edebug-display-freq-count)
- (setq unread-command-char (read-char))
+ (setq unread-command-events
+ (append unread-command-events (list (read-event))))
;; Yuck! This doesn't seem to work at all for me.
(undo)))
@@ -4352,87 +4258,6 @@ With prefix argument, make it a temporary breakpoint."
(easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus)
-;;; Byte-compiler
-
-;; Extension for bytecomp to resolve undefined function references.
-;; Requires new byte compiler.
-
-;; Reenable byte compiler warnings about unread-command-char and -event.
-;; Disabled before edebug-recursive-edit.
-(eval-when-compile
- (if edebug-unread-command-char-warning
- (put 'unread-command-char 'byte-obsolete-variable
- edebug-unread-command-char-warning)))
-
-(eval-when-compile
- ;; The body of eval-when-compile seems to get evaluated with eval-defun.
- ;; We only want to evaluate when actually byte compiling.
- ;; But it is OK to evaluate as long as byte-compiler has been loaded.
- (if (featurep 'byte-compile) (progn
-
- (defun byte-compile-resolve-functions (funcs)
- "Say it is OK for the named functions to be unresolved."
- (mapc
- (function
- (lambda (func)
- (setq byte-compile-unresolved-functions
- (delq (assq func byte-compile-unresolved-functions)
- byte-compile-unresolved-functions))))
- funcs)
- nil)
-
- '(defun byte-compile-resolve-free-references (vars)
- "Say it is OK for the named variables to be referenced."
- (mapcar
- (function
- (lambda (var)
- (setq byte-compile-free-references
- (delq var byte-compile-free-references))))
- vars)
- nil)
-
- '(defun byte-compile-resolve-free-assignments (vars)
- "Say it is OK for the named variables to be assigned."
- (mapcar
- (function
- (lambda (var)
- (setq byte-compile-free-assignments
- (delq var byte-compile-free-assignments))))
- vars)
- nil)
-
- (byte-compile-resolve-functions
- '(reporter-submit-bug-report
- edebug-gensym ;; also in cl.el
- ;; Interfaces to standard functions.
- edebug-original-eval-defun
- edebug-original-read
- edebug-get-buffer-window
- edebug-mark
- edebug-mark-marker
- edebug-input-pending-p
- edebug-sit-for
- edebug-prin1-to-string
- edebug-format
- ;; lemacs
- zmacs-deactivate-region
- popup-menu
- ;; CL
- cl-macroexpand-all
- ;; And believe it or not, the byte compiler doesn't know about:
- byte-compile-resolve-functions
- ))
-
- '(byte-compile-resolve-free-references
- '(read-expression-history
- read-expression-map))
-
- '(byte-compile-resolve-free-assignments
- '(read-expression-history))
-
- )))
-
-
;;; Autoloading of Edebug accessories
;; edebug-cl-read and cl-read are available from [email protected]
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 666e31f690..64aac4b81d 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -431,6 +431,61 @@ if that value is non-nil."
(add-hook 'completion-at-point-functions
'lisp-completion-at-point nil 'local))
+;;; Emacs Lisp Byte-Code mode
+
+(eval-and-compile
+ (defconst emacs-list-byte-code-comment-re
+ (concat "\\(#\\)@\\([0-9]+\\) "
+ ;; Make sure it's a docstring and not a lazy-loaded byte-code.
+ "\\(?:[^(]\\|([^\"]\\)")))
+
+(defun emacs-lisp-byte-code-comment (end &optional _point)
+ "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files."
+ (let ((ppss (syntax-ppss)))
+ (when (and (nth 4 ppss)
+ (eq (char-after (nth 8 ppss)) ?#))
+ (let* ((n (save-excursion
+ (goto-char (nth 8 ppss))
+ (when (looking-at emacs-list-byte-code-comment-re)
+ (string-to-number (match-string 2)))))
+ ;; `maxdiff' tries to make sure the loop below terminates.
+ (maxdiff n))
+ (when n
+ (let* ((bchar (match-end 2))
+ (b (position-bytes bchar)))
+ (goto-char (+ b n))
+ (while (let ((diff (- (position-bytes (point)) b n)))
+ (unless (zerop diff)
+ (when (> diff maxdiff) (setq diff maxdiff))
+ (forward-char (- diff))
+ (setq maxdiff (if (> diff 0) diff
+ (max (1- maxdiff) 1)))
+ t))))
+ (if (<= (point) end)
+ (put-text-property (1- (point)) (point)
+ 'syntax-table
+ (string-to-syntax "> b"))
+ (goto-char end)))))))
+
+(defun emacs-lisp-byte-code-syntax-propertize (start end)
+ (emacs-lisp-byte-code-comment end (point))
+ (funcall
+ (syntax-propertize-rules
+ (emacs-list-byte-code-comment-re
+ (1 (prog1 "< b" (emacs-lisp-byte-code-comment end (point))))))
+ start end))
+
+(add-to-list 'auto-mode-alist '("\\.elc\\'" . emacs-lisp-byte-code-mode))
+(define-derived-mode emacs-lisp-byte-code-mode emacs-lisp-mode
+ "Elisp-Byte-Code"
+ "Major mode for *.elc files."
+ ;; TODO: Add way to disassemble byte-code under point.
+ (setq-local open-paren-in-column-0-is-defun-start nil)
+ (setq-local syntax-propertize-function
+ #'emacs-lisp-byte-code-syntax-propertize))
+
+;;; Generic Lisp mode.
+
(defvar lisp-mode-map
(let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap "Lisp")))
@@ -730,10 +785,12 @@ POS specifies the starting position where EXP was found and defaults to point."
(let ((vars ()))
(goto-char (point-min))
(while (re-search-forward
- "^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
+ "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
pos t)
(let ((var (intern (match-string 1))))
- (unless (special-variable-p var)
+ (and (not (special-variable-p var))
+ (save-excursion
+ (zerop (car (syntax-ppss (match-beginning 0)))))
(push var vars))))
`(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
@@ -820,7 +877,6 @@ if it already has a value.\)
With argument, insert value in current buffer after the defun.
Return the result of evaluation."
- (interactive "P")
;; FIXME: the print-length/level bindings should only be applied while
;; printing, not while evaluating.
(let ((debug-on-error eval-expression-debug-on-error)
@@ -925,6 +981,7 @@ rigidly along with this one."
(if (or (null indent) (looking-at "\\s<\\s<\\s<"))
;; Don't alter indentation of a ;;; comment line
;; or a line that starts in a string.
+ ;; FIXME: inconsistency: comment-indent moves ;;; to column 0.
(goto-char (- (point-max) pos))
(if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<")))
;; Single-semicolon comment lines should be indented
@@ -939,18 +996,7 @@ rigidly along with this one."
;; If initial point was within line's indentation,
;; position after the indentation. Else stay at same point in text.
(if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos)))
- ;; If desired, shift remaining lines of expression the same amount.
- (and whole-exp (not (zerop shift-amt))
- (save-excursion
- (goto-char beg)
- (forward-sexp 1)
- (setq end (point))
- (goto-char beg)
- (forward-line 1)
- (setq beg (point))
- (> end beg))
- (indent-code-rigidly beg end shift-amt)))))
+ (goto-char (- (point-max) pos))))))
(defvar calculate-lisp-indent-last-sexp)
@@ -1230,7 +1276,6 @@ Lisp function does not specify a special indentation."
(put 'prog2 'lisp-indent-function 2)
(put 'save-excursion 'lisp-indent-function 0)
(put 'save-restriction 'lisp-indent-function 0)
-(put 'save-match-data 'lisp-indent-function 0)
(put 'save-current-buffer 'lisp-indent-function 0)
(put 'let 'lisp-indent-function 1)
(put 'let* 'lisp-indent-function 1)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 70eab14983..394225d697 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -100,6 +100,17 @@ each clause."
(error (message "Compiler-macro error for %S: %S" (car form) err)
form)))
+(defun macroexp--eval-if-compile (&rest _forms)
+ "Pseudo function used internally by macroexp to delay warnings.
+The purpose is to delay warnings to bytecomp.el, so they can use things
+like `byte-compile-log-warning' to get better file-and-line-number data
+and also to avoid outputting the warning during normal execution."
+ nil)
+(put 'macroexp--eval-if-compile 'byte-compile
+ (lambda (form)
+ (mapc (lambda (x) (funcall (eval x))) (cdr form))
+ (byte-compile-constant nil)))
+
(defun macroexp--expand-all (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
@@ -112,14 +123,17 @@ Assumes the caller has bound `macroexpand-all-environment'."
(macroexpand (macroexp--all-forms form 1)
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
- (let ((new-form (macroexpand form macroexpand-all-environment)))
- (when (and (not (eq form new-form)) ;It was a macro call.
- (car-safe form)
- (symbolp (car form))
- (get (car form) 'byte-obsolete-info)
- (fboundp 'byte-compile-warn-obsolete))
- (byte-compile-warn-obsolete (car form)))
- (setq form new-form))
+ (let ((new-form
+ (macroexpand form macroexpand-all-environment)))
+ (setq form
+ (if (and (not (eq form new-form)) ;It was a macro call.
+ (car-safe form)
+ (symbolp (car form))
+ (get (car form) 'byte-obsolete-info))
+ `(progn (macroexp--eval-if-compile
+ (lambda () (byte-compile-warn-obsolete ',(car form))))
+ ,new-form)
+ new-form)))
(pcase form
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
@@ -323,6 +337,86 @@ symbol itself."
"Return non-nil if EXP can be copied without extra cost."
(or (symbolp exp) (macroexp-const-p exp)))
+;;; Load-time macro-expansion.
+
+;; Because macro-expansion used to be more lazy, eager macro-expansion
+;; tends to bump into previously harmless/unnoticeable cyclic-dependencies.
+;; So, we have to delay macro-expansion like we used to when we detect
+;; such a cycle, and we also want to help coders resolve those cycles (since
+;; they can be non-obvious) by providing a usefully trimmed backtrace
+;; (hopefully) highlighting the problem.
+
+(defun macroexp--backtrace ()
+ "Return the Elisp backtrace, more recent frames first."
+ (let ((bt ())
+ (i 0))
+ (while
+ (let ((frame (backtrace-frame i)))
+ (when frame
+ (push frame bt)
+ (setq i (1+ i)))))
+ (nreverse bt)))
+
+(defun macroexp--trim-backtrace-frame (frame)
+ (pcase frame
+ (`(,_ macroexpand (,head . ,_) . ,_) `(macroexpand (,head …)))
+ (`(,_ internal-macroexpand-for-load (,head ,second . ,_) . ,_)
+ (if (or (symbolp second)
+ (and (eq 'quote (car-safe second))
+ (symbolp (cadr second))))
+ `(macroexpand-all (,head ,second …))
+ '(macroexpand-all …)))
+ (`(,_ load-with-code-conversion ,name . ,_)
+ `(load ,(file-name-nondirectory name)))))
+
+(defvar macroexp--pending-eager-loads nil
+ "Stack of files currently undergoing eager macro-expansion.")
+
+(defun internal-macroexpand-for-load (form)
+ ;; Called from the eager-macroexpansion in readevalloop.
+ (cond
+ ;; Don't repeat the same warning for every top-level element.
+ ((eq 'skip (car macroexp--pending-eager-loads)) form)
+ ;; If we detect a cycle, skip macro-expansion for now, and output a warning
+ ;; with a trimmed backtrace.
+ ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
+ (let* ((bt (delq nil
+ (mapcar #'macroexp--trim-backtrace-frame
+ (macroexp--backtrace))))
+ (elem `(load ,(file-name-nondirectory load-file-name)))
+ (tail (member elem (cdr (member elem bt)))))
+ (if tail (setcdr tail (list '…)))
+ (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
+ (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
+ (mapconcat #'prin1-to-string (nreverse bt) " => "))
+ (push 'skip macroexp--pending-eager-loads)
+ form))
+ (t
+ (condition-case err
+ (let ((macroexp--pending-eager-loads
+ (cons load-file-name macroexp--pending-eager-loads)))
+ (macroexpand-all form))
+ (error
+ ;; Hopefully this shouldn't happen thanks to the cycle detection,
+ ;; but in case it does happen, let's catch the error and give the
+ ;; code a chance to macro-expand later.
+ (message "Eager macro-expansion failure: %S" err)
+ form)))))
+
+;; ¡¡¡ Big Ugly Hack !!!
+;; src/bootstrap-emacs is mostly used to compile .el files, so it needs
+;; macroexp, bytecomp, cconv, and byte-opt to be fast. Generally this is done
+;; by compiling those files first, but this only makes a difference if those
+;; files are not preloaded. But macroexp.el is preloaded so we reload it if
+;; the current version is interpreted and there's a compiled version available.
+(eval-when-compile
+ (add-hook 'emacs-startup-hook
+ (lambda ()
+ (and (not (byte-code-function-p
+ (symbol-function 'macroexpand-all)))
+ (locate-library "macroexp.elc")
+ (load "macroexp.elc")))))
+
(provide 'macroexp)
;;; macroexp.el ends here
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index e7806440bf..289751f494 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -123,16 +123,6 @@ Returns the number of actions taken."
map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map query-replace-map)
- (define-key map [?\C-\M-v] 'scroll-other-window)
- (define-key map [M-next] 'scroll-other-window)
- (define-key map [?\C-\M-\S-v] 'scroll-other-window-down)
- (define-key map [M-prior] 'scroll-other-window-down)
- ;; The above are rather inconvenient, so maybe we should
- ;; provide the non-other keys for the other-scroll as well.
- ;; (define-key map [?\C-v] 'scroll-other-window)
- ;; (define-key map [next] 'scroll-other-window)
- ;; (define-key map [?\M-v] 'scroll-other-window-down)
- ;; (define-key map [prior] 'scroll-other-window-down)
(dolist (elt action-alist)
(define-key map (vector (car elt)) (vector (nth 1 elt))))
map)))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 4aeed7e4d0..09e47b69b9 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -60,6 +60,8 @@
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
+;; FIXME: Now that macroexpansion is also performed when loading an interpreted
+;; file, this is not a real problem any more.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index a66d5972d8..2248dde8c0 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -28,8 +28,8 @@
;;; Code:
;; Layout of a timer vector:
-;; [triggered-p high-seconds low-seconds usecs psecs repeat-delay
-;; function args idle-delay]
+;; [triggered-p high-seconds low-seconds usecs repeat-delay
+;; function args idle-delay psecs]
;; triggered-p is nil if the timer is active (waiting to be triggered),
;; t if it is inactive ("already triggered", in theory)
@@ -42,7 +42,7 @@
(:type vector)
(:conc-name timer--))
(triggered t)
- high-seconds low-seconds usecs psecs repeat-delay function args idle-delay)
+ high-seconds low-seconds usecs repeat-delay function args idle-delay psecs)
(defun timerp (object)
"Return t if OBJECT is a timer."