mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

(byte-compile-protect-from-advice): New macro that

Browse source 
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.
This commit is contained in:
Richard M. Stallman 1994-02-25 00:54:15 +00:00
parent 71d7800099
commit d9e42bcf36
1 changed files with 109 additions and 78 deletions
Download patch file Download diff file Expand all files Collapse all files

187
lisp/emacs-lisp/bytecomp.el
View file

@ -1246,70 +1246,100 @@ With argument, insert value in current buffer after the form."
((message "%s" (prin1-to-string value))))))) ((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) (defun byte-compile-from-buffer (inbuffer &optional eval)
;; buffer --> output-buffer, or buffer --> eval form, return nil ;; buffer --> output-buffer, or buffer --> eval form, return nil
(let (outbuffer) (byte-compile-protect-from-advice
(let (;; Prevent truncation of flonums and lists as we read and print them (let (outbuffer)
(float-output-format nil) (let (;; Prevent truncation of flonums and lists as we read and print them
(case-fold-search nil) (float-output-format nil)
(print-length nil) (case-fold-search nil)
;; Simulate entry to byte-compile-top-level (print-length nil)
(byte-compile-constants nil) ;; Simulate entry to byte-compile-top-level
(byte-compile-variables nil) (byte-compile-constants nil)
(byte-compile-tag-number 0) (byte-compile-variables nil)
(byte-compile-depth 0) (byte-compile-tag-number 0)
(byte-compile-maxdepth 0) (byte-compile-depth 0)
(byte-compile-output nil) (byte-compile-maxdepth 0)
;; #### This is bound in b-c-close-variables. (byte-compile-output nil)
;; (byte-compile-warnings (if (eq byte-compile-warnings t) ;; #### This is bound in b-c-close-variables.
;; byte-compile-warning-types ;; (byte-compile-warnings (if (eq byte-compile-warnings t)
;; byte-compile-warnings)) ;; byte-compile-warning-types
) ;; byte-compile-warnings))
(byte-compile-close-variables )
(save-excursion (byte-compile-close-variables
(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
(save-excursion (save-excursion
(set-buffer inbuffer) (setq outbuffer
(goto-char 1) (set-buffer (get-buffer-create " *Compiler Output*")))
(while (progn (erase-buffer)
(while (progn (skip-chars-forward " \t\n\^l") ;; (emacs-lisp-mode)
(looking-at ";")) (setq case-fold-search nil)
(forward-line 1))
(not (eobp))) ;; This is a kludge. Some operating systems (OS/2, DOS) need to
(byte-compile-file-form (read inbuffer))) ;; write files containing binary information specially.
;; Compile pending forms at end of file. ;; Under most circumstances, such files will be in binary
(byte-compile-flush-pending) ;; overwrite mode, so those OS's use that flag to guess how
(and (not eval) (byte-compile-insert-header)) ;; they should write their data. Advise them that .elc files
(byte-compile-warn-about-unresolved-functions) ;; need to be written carefully.
;; always do this? When calling multiple files, it (setq overwrite-mode 'overwrite-mode-binary))
;; would be useful to delay this warning until all have (displaying-byte-compile-warnings
;; been compiled. (save-excursion
(setq byte-compile-unresolved-functions nil))) (set-buffer inbuffer)
(save-excursion (goto-char 1)
(set-buffer outbuffer) (while (progn
(goto-char (point-min))))) (while (progn (skip-chars-forward " \t\n\^l")
(if (not eval) (looking-at ";"))
outbuffer (forward-line 1))
(while (condition-case nil (not (eobp)))
(progn (setq form (read outbuffer)) (byte-compile-file-form (read inbuffer)))
t) ;; Compile pending forms at end of file.
(end-of-file nil)) (byte-compile-flush-pending)
(eval form)) (and (not eval) (byte-compile-insert-header))
(kill-buffer outbuffer) (byte-compile-warn-about-unresolved-functions)
nil))) ;; 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))))
(defun byte-compile-insert-header () (defun byte-compile-insert-header ()
(save-excursion (save-excursion
@ -1786,23 +1816,24 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; 'progn or t -> a list of forms, ;; 'progn or t -> a list of forms,
;; 'lambda -> body of a lambda, ;; 'lambda -> body of a lambda,
;; 'file -> used at file-level. ;; 'file -> used at file-level.
(let ((byte-compile-constants nil) (byte-compile-protect-from-advice
(byte-compile-variables nil) (let ((byte-compile-constants nil)
(byte-compile-tag-number 0) (byte-compile-variables nil)
(byte-compile-depth 0) (byte-compile-tag-number 0)
(byte-compile-maxdepth 0) (byte-compile-depth 0)
(byte-compile-output nil)) (byte-compile-maxdepth 0)
(if (memq byte-optimize '(t source)) (byte-compile-output nil))
(setq form (byte-optimize-form form for-effect))) (if (memq byte-optimize '(t source))
(while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) (setq form (byte-optimize-form form for-effect)))
(setq form (nth 1 form))) (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
(if (and (eq 'byte-code (car-safe form)) (setq form (nth 1 form)))
(not (memq byte-optimize '(t byte))) (if (and (eq 'byte-code (car-safe form))
(stringp (nth 1 form)) (vectorp (nth 2 form)) (not (memq byte-optimize '(t byte)))
(natnump (nth 3 form))) (stringp (nth 1 form)) (vectorp (nth 2 form))
form (natnump (nth 3 form)))
(byte-compile-form form for-effect) form
(byte-compile-out-toplevel for-effect output-type)))) (byte-compile-form form for-effect)
(byte-compile-out-toplevel for-effect output-type)))))
(defun byte-compile-out-toplevel (&optional for-effect output-type) (defun byte-compile-out-toplevel (&optional for-effect output-type)
(if for-effect (if for-effect