mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-22 05:31:01 -08:00
upstream
This commit is contained in:
Joakim Verona
commit
b035a30e5c
185 changed files with 5965 additions and 6281 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" "a1ca04b3f2acc7c9b06f45ef5486d443")
|
||||
;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
|
||||
;;;;;; "cl-macs" "cl-macs.el" "00526d56a1062b9c308cf37b59374f2b")
|
||||
;;; 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,9 @@ 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-backtrace nil
|
||||
"The contents of the previous backtrace (including text properties).
|
||||
This is to optimize `debugger-make-xrefs'.")
|
||||
|
|
@ -133,7 +169,7 @@ first will be printed into the backtrace buffer."
|
|||
(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!
|
||||
|
|
@ -184,78 +220,63 @@ 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"))
|
||||
(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
|
||||
`((display-buffer-reuse-window
|
||||
display-buffer-in-previous-window)
|
||||
. (,(when debugger-previous-window
|
||||
`(previous-window . ,debugger-previous-window)))))
|
||||
(setq debugger-window (selected-window))
|
||||
(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))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue