# HG changeset patch # User Richard M. Stallman # Date 762137655 0 # Node ID 65adb7b035fd0ecc413ad33875f63c4744a7a6c0 # Parent 2f02deab5b9e7842ba9e55d15b00b9fe5b2006f7 (byte-compile-protect-from-advice): New macro that temporarily deactivates advice of `defun/defmacro' while BODY is run. (byte-compile-from-buffer, byte-compile-top-level): Use `byte-compile-protect-from-advice' to protect compilation. diff -r 2f02deab5b9e -r 65adb7b035fd lisp/emacs-lisp/bytecomp.el --- a/lisp/emacs-lisp/bytecomp.el Thu Feb 24 23:43:30 1994 +0000 +++ b/lisp/emacs-lisp/bytecomp.el Fri Feb 25 00:54:15 1994 +0000 @@ -1246,70 +1246,100 @@ ((message "%s" (prin1-to-string value))))))) +(defmacro byte-compile-protect-from-advice (&rest body) + ;; Temporarily deactivates advice of `defun/defmacro' while BODY is run. + ;; After completion of BODY the initial advice state is reinstated. + ;; If `defun/defmacro' are actively advised during compilation then the + ;; compilation of nested `defun/defmacro's produces incorrect code which + ;; is the motivation for this macro. It calls the functions `ad-is-active', + ;; `ad-activate' and `ad-deactivate' which will be reported as undefined + ;; functions during the compilation of the compiler. + (` (let (;; make sure no `require' activates them by + ;; accident via a call to `ad-start-advice': + (ad-advised-definers '(fset defalias define-function)) + defun-active-p defmacro-active-p) + (cond (;; check whether Advice is loaded: + (fboundp 'ad-scan-byte-code-for-fsets) + ;; save activation state of `defun/defmacro' and + ;; deactivate them if their advice is active: + (if (setq defun-active-p (ad-is-active 'defun)) + (ad-deactivate 'defun)) + (if (setq defmacro-active-p (ad-is-active 'defmacro)) + (ad-deactivate 'defmacro)))) + (unwind-protect + (progn + (,@ body)) + ;; reactivate what was active before: + (if defun-active-p + (ad-activate 'defun)) + (if defmacro-active-p + (ad-activate 'defmacro)))))) + (defun byte-compile-from-buffer (inbuffer &optional eval) ;; buffer --> output-buffer, or buffer --> eval form, return nil - (let (outbuffer) - (let (;; Prevent truncation of flonums and lists as we read and print them - (float-output-format nil) - (case-fold-search nil) - (print-length nil) - ;; Simulate entry to byte-compile-top-level - (byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil) -;; #### This is bound in b-c-close-variables. -;; (byte-compile-warnings (if (eq byte-compile-warnings t) -;; byte-compile-warning-types -;; byte-compile-warnings)) - ) - (byte-compile-close-variables - (save-excursion - (setq outbuffer - (set-buffer (get-buffer-create " *Compiler Output*"))) - (erase-buffer) - ;; (emacs-lisp-mode) - (setq case-fold-search nil) + (byte-compile-protect-from-advice + (let (outbuffer) + (let (;; Prevent truncation of flonums and lists as we read and print them + (float-output-format nil) + (case-fold-search nil) + (print-length nil) + ;; Simulate entry to byte-compile-top-level + (byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil) + ;; #### This is bound in b-c-close-variables. + ;; (byte-compile-warnings (if (eq byte-compile-warnings t) + ;; byte-compile-warning-types + ;; byte-compile-warnings)) + ) + (byte-compile-close-variables + (save-excursion + (setq outbuffer + (set-buffer (get-buffer-create " *Compiler Output*"))) + (erase-buffer) + ;; (emacs-lisp-mode) + (setq case-fold-search nil) - ;; This is a kludge. Some operating systems (OS/2, DOS) need to - ;; write files containing binary information specially. - ;; Under most circumstances, such files will be in binary - ;; overwrite mode, so those OS's use that flag to guess how - ;; they should write their data. Advise them that .elc files - ;; need to be written carefully. - (setq overwrite-mode 'overwrite-mode-binary)) - (displaying-byte-compile-warnings + ;; This is a kludge. Some operating systems (OS/2, DOS) need to + ;; write files containing binary information specially. + ;; Under most circumstances, such files will be in binary + ;; overwrite mode, so those OS's use that flag to guess how + ;; they should write their data. Advise them that .elc files + ;; need to be written carefully. + (setq overwrite-mode 'overwrite-mode-binary)) + (displaying-byte-compile-warnings + (save-excursion + (set-buffer inbuffer) + (goto-char 1) + (while (progn + (while (progn (skip-chars-forward " \t\n\^l") + (looking-at ";")) + (forward-line 1)) + (not (eobp))) + (byte-compile-file-form (read inbuffer))) + ;; Compile pending forms at end of file. + (byte-compile-flush-pending) + (and (not eval) (byte-compile-insert-header)) + (byte-compile-warn-about-unresolved-functions) + ;; always do this? When calling multiple files, it + ;; would be useful to delay this warning until all have + ;; been compiled. + (setq byte-compile-unresolved-functions nil))) (save-excursion - (set-buffer inbuffer) - (goto-char 1) - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (byte-compile-file-form (read inbuffer))) - ;; Compile pending forms at end of file. - (byte-compile-flush-pending) - (and (not eval) (byte-compile-insert-header)) - (byte-compile-warn-about-unresolved-functions) - ;; always do this? When calling multiple files, it - ;; would be useful to delay this warning until all have - ;; been compiled. - (setq byte-compile-unresolved-functions nil))) - (save-excursion - (set-buffer outbuffer) - (goto-char (point-min))))) - (if (not eval) - outbuffer - (while (condition-case nil - (progn (setq form (read outbuffer)) - t) - (end-of-file nil)) - (eval form)) - (kill-buffer outbuffer) - nil))) + (set-buffer outbuffer) + (goto-char (point-min))))) + (if (not eval) + outbuffer + (while (condition-case nil + (progn (setq form (read outbuffer)) + t) + (end-of-file nil)) + (eval form)) + (kill-buffer outbuffer) + nil)))) (defun byte-compile-insert-header () (save-excursion @@ -1786,23 +1816,24 @@ ;; 'progn or t -> a list of forms, ;; 'lambda -> body of a lambda, ;; 'file -> used at file-level. - (let ((byte-compile-constants nil) - (byte-compile-variables nil) - (byte-compile-tag-number 0) - (byte-compile-depth 0) - (byte-compile-maxdepth 0) - (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (byte-compile-protect-from-advice + (let ((byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil)) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type))))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect