mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 14:30:50 -08:00
Make symbols with positions work with native compilation
This version of the software should bootstrap Emacs successfully with native compilation enabled. * lisp/emacs-lisp/bytecomp.el (byte-compile-strip-s-p-1) (byte-compile-strip-symbol-positions): Rename and move to macroexp.el. Rename calls to these functions throughout the file. (byte-compile-initial-macro-environment): In the code sections for eval-when-compile and eval-and-compile, call macroexp-strip-symbol-positions before evaluating code. (byte-compile-file, byte-compile-output-file-form) (byte-compile-file-form-defmumble, byte-compile, batch-byte-compile): Call macroexp-strip-symbol-positions from code being passed to the native compiler. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): Remove, replacing them with the renamed functions in macroexp.el. (cl-define-compiler-macro): Apply macroexp-strip-symbol-positions to ARGS and BODY. * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Use `null' to compile byte-not rather than a compilation of `eq'. (comp--native-compile): bind symbols-with-pos-enabled to t. * lisp/emacs-lisp/macroexp.el (byte-compile--ssp-conses-seen) (byte-compile--ssp-vectors-seen, byte-compile--ssp-records-seen): Provisional auxiliary variables to support the following functions. (macroexp--strip-s-p-2, byte-compile-strip-s-p-1) (macroexp-strip-symbol-positions): Functions moved from bytecomp.el, renamed, and further developed. (macroexp--compiler-macro): Bind symbol-with-pos-enabled to t around the call to `handler'. (internal-macroexpand-for-load): Strip symbol positions from the form being eagerly expanded for macros. * src/comp.c (F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM): New macro for a relocation symbol. (comp_t): New elements bool_ptr_type, f_symbols_with_pos_enabled_ref, lisp_symbol_with_position, lisp_symbol_with_position_header, lisp_symbol_with_position_sym, lisp_symbol_with_position_pos, lisp_symbol_with_position_type, lisp_symbol_with_position_ptr_type, get_symbol_with_position. (helper_GET_SYMBOL_WITH_POSITION): New function. (emit_BASE_EQ): Function rename from emit_EQ. (emit_AND, emit_OR, emit_BARE_SYMBOL_P, emit_SYMBOL_WITH_POS_P) (emit_SYMBOL_WITH_POS_SYM): New functions. (emit_EQ): New function which handles symbols with position correctly. (emit_NILP): Use emit_BASE_EQ rather than emit_EQ. (emit_limple_insn): When emitting a conditional branch, check each operand for being a literal Qnil, and if one of them is, use emit_BASE_EQ rather than emit_EQ. (declare_runtime_imported_funcs): Declare helper_GET_SYMBOL_WITH_POSITION. (emit_ctxt_code): Export the global F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM. (define_lisp_symbol_with_position, define_GET_SYMBOL_WITH_POSITION): New functions. (Fcomp__init_ctxt): Initialise comp.bool_ptr_type, call the two new define_.... functions. (load_comp_unit): Initialise **f_symbols_with_pos_enabled_reloc. * src/fns.c (Fput): Strip positions from symbols in PROPNAME and VALUE.
This commit is contained in:
Alan Mackenzie
parent
8f1106ddf2
commit
1cd188799f
6 changed files with 561 additions and 307 deletions
|
|
@ -465,36 +465,6 @@ This is used by the warning message routines to determine a
|
|||
source code position. The most accessible element is the current
|
||||
most deeply nested form.")
|
||||
|
||||
(defun byte-compile-strip-s-p-1 (arg)
|
||||
"Strip all positions from symbols in ARG, destructively modifying ARG.
|
||||
Return the modified ARG."
|
||||
(cond
|
||||
((symbolp arg)
|
||||
(bare-symbol arg))
|
||||
((consp arg)
|
||||
(let ((a arg))
|
||||
(while (consp (cdr a))
|
||||
(setcar a (byte-compile-strip-s-p-1 (car a)))
|
||||
(setq a (cdr a)))
|
||||
(setcar a (byte-compile-strip-s-p-1 (car a)))
|
||||
;; (if (cdr a)
|
||||
(unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
|
||||
(setcdr a (byte-compile-strip-s-p-1 (cdr a)))))
|
||||
arg)
|
||||
((vectorp arg)
|
||||
(let ((i 0)
|
||||
(len (length arg)))
|
||||
(while (< i len)
|
||||
(aset arg i (byte-compile-strip-s-p-1 (aref arg i)))
|
||||
(setq i (1+ i))))
|
||||
arg)
|
||||
(t arg)))
|
||||
|
||||
(defun byte-compile-strip-symbol-positions (arg)
|
||||
"Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
|
||||
(let ((arg1 (copy-tree arg t)))
|
||||
(byte-compile-strip-s-p-1 arg1)))
|
||||
|
||||
(defun byte-compile-recurse-toplevel (form non-toplevel-case)
|
||||
"Implement `eval-when-compile' and `eval-and-compile'.
|
||||
Return the compile-time value of FORM."
|
||||
|
|
@ -535,8 +505,9 @@ Return the compile-time value of FORM."
|
|||
byte-compile-new-defuns))
|
||||
(setf result
|
||||
(byte-compile-eval
|
||||
(byte-compile-top-level
|
||||
(byte-compile-preprocess form)))))))
|
||||
(macroexp-strip-symbol-positions
|
||||
(byte-compile-top-level
|
||||
(byte-compile-preprocess form))))))))
|
||||
(list 'quote result))))
|
||||
(eval-and-compile . ,(lambda (&rest body)
|
||||
(byte-compile-recurse-toplevel
|
||||
|
|
@ -547,10 +518,13 @@ Return the compile-time value of FORM."
|
|||
;; or byte-compile-file-form.
|
||||
(let* ((print-symbols-bare t)
|
||||
(expanded
|
||||
(macroexpand-all
|
||||
form
|
||||
macroexpand-all-environment)))
|
||||
(eval expanded lexical-binding)
|
||||
(macroexpand-all
|
||||
form
|
||||
macroexpand-all-environment)))
|
||||
(eval
|
||||
(macroexp-strip-symbol-positions
|
||||
expanded)
|
||||
lexical-binding)
|
||||
expanded)))))
|
||||
(with-suppressed-warnings
|
||||
. ,(lambda (warnings &rest body)
|
||||
|
|
@ -1435,7 +1409,7 @@ function directly; use `byte-compile-warn' or
|
|||
|
||||
(defun byte-compile-warn (format &rest args)
|
||||
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message."
|
||||
(setq args (mapcar #'byte-compile-strip-symbol-positions args))
|
||||
(setq args (mapcar #'macroexp-strip-symbol-positions args))
|
||||
(setq format (apply #'format-message format args))
|
||||
(if byte-compile-error-on-warn
|
||||
(error "%s" format) ; byte-compile-file catches and logs it
|
||||
|
|
@ -2117,175 +2091,179 @@ See also `emacs-lisp-byte-compile-and-load'."
|
|||
|
||||
;; Force logging of the file name for each file compiled.
|
||||
(setq byte-compile-last-logged-file nil)
|
||||
(let ((byte-compile-current-file filename)
|
||||
(byte-compile-current-group nil)
|
||||
(set-auto-coding-for-load t)
|
||||
(byte-compile--seen-defvars nil)
|
||||
(byte-compile--known-dynamic-vars
|
||||
(byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
|
||||
target-file input-buffer output-buffer
|
||||
byte-compile-dest-file byte-compiler-error-flag)
|
||||
(setq target-file (byte-compile-dest-file filename))
|
||||
(setq byte-compile-dest-file target-file)
|
||||
(with-current-buffer
|
||||
;; It would be cleaner to use a temp buffer, but if there was
|
||||
;; an error, we leave this buffer around for diagnostics.
|
||||
;; Its name is documented in the lispref.
|
||||
(setq input-buffer (get-buffer-create
|
||||
(concat " *Compiler Input*"
|
||||
(if (zerop byte-compile-level) ""
|
||||
(format "-%s" byte-compile-level)))))
|
||||
(erase-buffer)
|
||||
(setq buffer-file-coding-system nil)
|
||||
;; Always compile an Emacs Lisp file as multibyte
|
||||
;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
|
||||
(set-buffer-multibyte t)
|
||||
(insert-file-contents filename)
|
||||
;; Mimic the way after-insert-file-set-coding can make the
|
||||
;; buffer unibyte when visiting this file.
|
||||
(when (or (eq last-coding-system-used 'no-conversion)
|
||||
(eq (coding-system-type last-coding-system-used) 5))
|
||||
;; For coding systems no-conversion and raw-text...,
|
||||
;; edit the buffer as unibyte.
|
||||
(set-buffer-multibyte nil))
|
||||
;; Run hooks including the uncompression hook.
|
||||
;; If they change the file name, then change it for the output also.
|
||||
(let ((buffer-file-name filename)
|
||||
(dmm (default-value 'major-mode))
|
||||
;; Ignore unsafe local variables.
|
||||
;; We only care about a few of them for our purposes.
|
||||
(enable-local-variables :safe)
|
||||
(enable-local-eval nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq-default major-mode 'emacs-lisp-mode)
|
||||
;; Arg of t means don't alter enable-local-variables.
|
||||
(delay-mode-hooks (normal-mode t)))
|
||||
(setq-default major-mode dmm))
|
||||
;; There may be a file local variable setting (bug#10419).
|
||||
(setq buffer-read-only nil
|
||||
filename buffer-file-name))
|
||||
;; Don't inherit lexical-binding from caller (bug#12938).
|
||||
(unless (local-variable-p 'lexical-binding)
|
||||
(setq-local lexical-binding nil))
|
||||
;; Set the default directory, in case an eval-when-compile uses it.
|
||||
(setq default-directory (file-name-directory filename)))
|
||||
;; Check if the file's local variables explicitly specify not to
|
||||
;; compile this file.
|
||||
(if (with-current-buffer input-buffer no-byte-compile)
|
||||
(progn
|
||||
;; (message "%s not compiled because of `no-byte-compile: %s'"
|
||||
;; (byte-compile-abbreviate-file filename)
|
||||
;; (with-current-buffer input-buffer no-byte-compile))
|
||||
(when (and target-file (file-exists-p target-file))
|
||||
(message "%s deleted because of `no-byte-compile: %s'"
|
||||
(byte-compile-abbreviate-file target-file)
|
||||
(buffer-local-value 'no-byte-compile input-buffer))
|
||||
(condition-case nil (delete-file target-file) (error nil)))
|
||||
;; We successfully didn't compile this file.
|
||||
'no-byte-compile)
|
||||
(when byte-compile-verbose
|
||||
(message "Compiling %s..." filename))
|
||||
;; It is important that input-buffer not be current at this call,
|
||||
;; so that the value of point set in input-buffer
|
||||
;; within byte-compile-from-buffer lingers in that buffer.
|
||||
(setq output-buffer
|
||||
(save-current-buffer
|
||||
(let ((symbols-with-pos-enabled t)
|
||||
(byte-compile-level (1+ byte-compile-level)))
|
||||
(byte-compile-from-buffer input-buffer))))
|
||||
(if byte-compiler-error-flag
|
||||
nil
|
||||
(when byte-compile-verbose
|
||||
(message "Compiling %s...done" filename))
|
||||
(kill-buffer input-buffer)
|
||||
(with-current-buffer output-buffer
|
||||
(when (and target-file
|
||||
(or (not byte-native-compiling)
|
||||
(and byte-native-compiling byte+native-compile)))
|
||||
(goto-char (point-max))
|
||||
(insert "\n") ; aaah, unix.
|
||||
(cond
|
||||
((and (file-writable-p target-file)
|
||||
;; We attempt to create a temporary file in the
|
||||
;; target directory, so the target directory must be
|
||||
;; writable.
|
||||
(file-writable-p
|
||||
(file-name-directory
|
||||
;; Need to expand in case TARGET-FILE doesn't
|
||||
;; include a directory (Bug#45287).
|
||||
(expand-file-name target-file))))
|
||||
;; We must disable any code conversion here.
|
||||
(let* ((coding-system-for-write 'no-conversion)
|
||||
;; Write to a tempfile so that if another Emacs
|
||||
;; process is trying to load target-file (eg in a
|
||||
;; parallel bootstrap), it does not risk getting a
|
||||
;; half-finished file. (Bug#4196)
|
||||
(tempfile
|
||||
(make-temp-file (when (file-writable-p target-file)
|
||||
(expand-file-name target-file))))
|
||||
(default-modes (default-file-modes))
|
||||
(temp-modes (logand default-modes #o600))
|
||||
(desired-modes (logand default-modes #o666))
|
||||
(kill-emacs-hook
|
||||
(cons (lambda () (ignore-errors
|
||||
(delete-file tempfile)))
|
||||
kill-emacs-hook)))
|
||||
(unless (= temp-modes desired-modes)
|
||||
(set-file-modes tempfile desired-modes 'nofollow))
|
||||
(write-region (point-min) (point-max) tempfile nil 1)
|
||||
;; This has the intentional side effect that any
|
||||
;; hard-links to target-file continue to
|
||||
;; point to the old file (this makes it possible
|
||||
;; for installed files to share disk space with
|
||||
;; the build tree, without causing problems when
|
||||
;; emacs-lisp files in the build tree are
|
||||
;; recompiled). Previously this was accomplished by
|
||||
;; deleting target-file before writing it.
|
||||
(if byte-native-compiling
|
||||
;; Defer elc final renaming.
|
||||
(setf byte-to-native-output-file
|
||||
(cons tempfile target-file))
|
||||
(rename-file tempfile target-file t)))
|
||||
(or noninteractive
|
||||
byte-native-compiling
|
||||
(message "Wrote %s" target-file)))
|
||||
((file-writable-p target-file)
|
||||
;; In case the target directory isn't writable (see e.g. Bug#44631),
|
||||
;; try writing to the output file directly. We must disable any
|
||||
;; code conversion here.
|
||||
(let ((coding-system-for-write 'no-conversion))
|
||||
(with-file-modes (logand (default-file-modes) #o666)
|
||||
(write-region (point-min) (point-max) target-file nil 1)))
|
||||
(or noninteractive (message "Wrote %s" target-file)))
|
||||
(t
|
||||
;; This is just to give a better error message than write-region
|
||||
(let ((exists (file-exists-p target-file)))
|
||||
(signal (if exists 'file-error 'file-missing)
|
||||
(list "Opening output file"
|
||||
(if exists
|
||||
"Cannot overwrite file"
|
||||
"Directory not writable or nonexistent")
|
||||
target-file))))))
|
||||
(kill-buffer (current-buffer)))
|
||||
(if (and byte-compile-generate-call-tree
|
||||
(or (eq t byte-compile-generate-call-tree)
|
||||
(y-or-n-p (format "Report call tree for %s? "
|
||||
filename))))
|
||||
(save-excursion
|
||||
(display-call-tree filename)))
|
||||
(let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
|
||||
(when (and gen-dynvars (not (equal gen-dynvars ""))
|
||||
byte-compile--seen-defvars)
|
||||
(let ((dynvar-file (concat target-file ".dynvars")))
|
||||
(message "Generating %s" dynvar-file)
|
||||
(with-temp-buffer
|
||||
(dolist (var (delete-dups byte-compile--seen-defvars))
|
||||
(insert (format "%S\n" (cons var filename))))
|
||||
(write-region (point-min) (point-max) dynvar-file)))))
|
||||
(if load
|
||||
(load target-file))
|
||||
t))))
|
||||
(prog1
|
||||
(let ((byte-compile-current-file filename)
|
||||
(byte-compile-current-group nil)
|
||||
(set-auto-coding-for-load t)
|
||||
(byte-compile--seen-defvars nil)
|
||||
(byte-compile--known-dynamic-vars
|
||||
(byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
|
||||
target-file input-buffer output-buffer
|
||||
byte-compile-dest-file byte-compiler-error-flag)
|
||||
(setq target-file (byte-compile-dest-file filename))
|
||||
(setq byte-compile-dest-file target-file)
|
||||
(with-current-buffer
|
||||
;; It would be cleaner to use a temp buffer, but if there was
|
||||
;; an error, we leave this buffer around for diagnostics.
|
||||
;; Its name is documented in the lispref.
|
||||
(setq input-buffer (get-buffer-create
|
||||
(concat " *Compiler Input*"
|
||||
(if (zerop byte-compile-level) ""
|
||||
(format "-%s" byte-compile-level)))))
|
||||
(erase-buffer)
|
||||
(setq buffer-file-coding-system nil)
|
||||
;; Always compile an Emacs Lisp file as multibyte
|
||||
;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
|
||||
(set-buffer-multibyte t)
|
||||
(insert-file-contents filename)
|
||||
;; Mimic the way after-insert-file-set-coding can make the
|
||||
;; buffer unibyte when visiting this file.
|
||||
(when (or (eq last-coding-system-used 'no-conversion)
|
||||
(eq (coding-system-type last-coding-system-used) 5))
|
||||
;; For coding systems no-conversion and raw-text...,
|
||||
;; edit the buffer as unibyte.
|
||||
(set-buffer-multibyte nil))
|
||||
;; Run hooks including the uncompression hook.
|
||||
;; If they change the file name, then change it for the output also.
|
||||
(let ((buffer-file-name filename)
|
||||
(dmm (default-value 'major-mode))
|
||||
;; Ignore unsafe local variables.
|
||||
;; We only care about a few of them for our purposes.
|
||||
(enable-local-variables :safe)
|
||||
(enable-local-eval nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq-default major-mode 'emacs-lisp-mode)
|
||||
;; Arg of t means don't alter enable-local-variables.
|
||||
(delay-mode-hooks (normal-mode t)))
|
||||
(setq-default major-mode dmm))
|
||||
;; There may be a file local variable setting (bug#10419).
|
||||
(setq buffer-read-only nil
|
||||
filename buffer-file-name))
|
||||
;; Don't inherit lexical-binding from caller (bug#12938).
|
||||
(unless (local-variable-p 'lexical-binding)
|
||||
(setq-local lexical-binding nil))
|
||||
;; Set the default directory, in case an eval-when-compile uses it.
|
||||
(setq default-directory (file-name-directory filename)))
|
||||
;; Check if the file's local variables explicitly specify not to
|
||||
;; compile this file.
|
||||
(if (with-current-buffer input-buffer no-byte-compile)
|
||||
(progn
|
||||
;; (message "%s not compiled because of `no-byte-compile: %s'"
|
||||
;; (byte-compile-abbreviate-file filename)
|
||||
;; (with-current-buffer input-buffer no-byte-compile))
|
||||
(when (and target-file (file-exists-p target-file))
|
||||
(message "%s deleted because of `no-byte-compile: %s'"
|
||||
(byte-compile-abbreviate-file target-file)
|
||||
(buffer-local-value 'no-byte-compile input-buffer))
|
||||
(condition-case nil (delete-file target-file) (error nil)))
|
||||
;; We successfully didn't compile this file.
|
||||
'no-byte-compile)
|
||||
(when byte-compile-verbose
|
||||
(message "Compiling %s..." filename))
|
||||
;; It is important that input-buffer not be current at this call,
|
||||
;; so that the value of point set in input-buffer
|
||||
;; within byte-compile-from-buffer lingers in that buffer.
|
||||
(setq output-buffer
|
||||
(save-current-buffer
|
||||
(let ((symbols-with-pos-enabled t)
|
||||
(byte-compile-level (1+ byte-compile-level)))
|
||||
(byte-compile-from-buffer input-buffer))))
|
||||
(if byte-compiler-error-flag
|
||||
nil
|
||||
(when byte-compile-verbose
|
||||
(message "Compiling %s...done" filename))
|
||||
(kill-buffer input-buffer)
|
||||
(with-current-buffer output-buffer
|
||||
(when (and target-file
|
||||
(or (not byte-native-compiling)
|
||||
(and byte-native-compiling byte+native-compile)))
|
||||
(goto-char (point-max))
|
||||
(insert "\n") ; aaah, unix.
|
||||
(cond
|
||||
((and (file-writable-p target-file)
|
||||
;; We attempt to create a temporary file in the
|
||||
;; target directory, so the target directory must be
|
||||
;; writable.
|
||||
(file-writable-p
|
||||
(file-name-directory
|
||||
;; Need to expand in case TARGET-FILE doesn't
|
||||
;; include a directory (Bug#45287).
|
||||
(expand-file-name target-file))))
|
||||
;; We must disable any code conversion here.
|
||||
(let* ((coding-system-for-write 'no-conversion)
|
||||
;; Write to a tempfile so that if another Emacs
|
||||
;; process is trying to load target-file (eg in a
|
||||
;; parallel bootstrap), it does not risk getting a
|
||||
;; half-finished file. (Bug#4196)
|
||||
(tempfile
|
||||
(make-temp-file (when (file-writable-p target-file)
|
||||
(expand-file-name target-file))))
|
||||
(default-modes (default-file-modes))
|
||||
(temp-modes (logand default-modes #o600))
|
||||
(desired-modes (logand default-modes #o666))
|
||||
(kill-emacs-hook
|
||||
(cons (lambda () (ignore-errors
|
||||
(delete-file tempfile)))
|
||||
kill-emacs-hook)))
|
||||
(unless (= temp-modes desired-modes)
|
||||
(set-file-modes tempfile desired-modes 'nofollow))
|
||||
(write-region (point-min) (point-max) tempfile nil 1)
|
||||
;; This has the intentional side effect that any
|
||||
;; hard-links to target-file continue to
|
||||
;; point to the old file (this makes it possible
|
||||
;; for installed files to share disk space with
|
||||
;; the build tree, without causing problems when
|
||||
;; emacs-lisp files in the build tree are
|
||||
;; recompiled). Previously this was accomplished by
|
||||
;; deleting target-file before writing it.
|
||||
(if byte-native-compiling
|
||||
;; Defer elc final renaming.
|
||||
(setf byte-to-native-output-file
|
||||
(cons tempfile target-file))
|
||||
(rename-file tempfile target-file t)))
|
||||
(or noninteractive
|
||||
byte-native-compiling
|
||||
(message "Wrote %s" target-file)))
|
||||
((file-writable-p target-file)
|
||||
;; In case the target directory isn't writable (see e.g. Bug#44631),
|
||||
;; try writing to the output file directly. We must disable any
|
||||
;; code conversion here.
|
||||
(let ((coding-system-for-write 'no-conversion))
|
||||
(with-file-modes (logand (default-file-modes) #o666)
|
||||
(write-region (point-min) (point-max) target-file nil 1)))
|
||||
(or noninteractive (message "Wrote %s" target-file)))
|
||||
(t
|
||||
;; This is just to give a better error message than write-region
|
||||
(let ((exists (file-exists-p target-file)))
|
||||
(signal (if exists 'file-error 'file-missing)
|
||||
(list "Opening output file"
|
||||
(if exists
|
||||
"Cannot overwrite file"
|
||||
"Directory not writable or nonexistent")
|
||||
target-file))))))
|
||||
(kill-buffer (current-buffer)))
|
||||
(if (and byte-compile-generate-call-tree
|
||||
(or (eq t byte-compile-generate-call-tree)
|
||||
(y-or-n-p (format "Report call tree for %s? "
|
||||
filename))))
|
||||
(save-excursion
|
||||
(display-call-tree filename)))
|
||||
(let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
|
||||
(when (and gen-dynvars (not (equal gen-dynvars ""))
|
||||
byte-compile--seen-defvars)
|
||||
(let ((dynvar-file (concat target-file ".dynvars")))
|
||||
(message "Generating %s" dynvar-file)
|
||||
(with-temp-buffer
|
||||
(dolist (var (delete-dups byte-compile--seen-defvars))
|
||||
(insert (format "%S\n" (cons var filename))))
|
||||
(write-region (point-min) (point-max) dynvar-file)))))
|
||||
(if load
|
||||
(load target-file))
|
||||
t)))
|
||||
;; Strip positions from symbols for the native compiler.
|
||||
(setq byte-to-native-top-level-forms
|
||||
(macroexp-strip-symbol-positions byte-to-native-top-level-forms))))
|
||||
|
||||
;;; compiling a single function
|
||||
;;;###autoload
|
||||
|
|
@ -2458,8 +2436,10 @@ Call from the source buffer."
|
|||
;; it here.
|
||||
(when byte-native-compiling
|
||||
;; Spill output for the native compiler here
|
||||
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
|
||||
byte-to-native-top-level-forms))
|
||||
(push
|
||||
(macroexp-strip-symbol-positions
|
||||
(make-byte-to-native-top-level :form form :lexical lexical-binding))
|
||||
byte-to-native-top-level-forms))
|
||||
(let ((print-escape-newlines t)
|
||||
(print-length nil)
|
||||
(print-level nil)
|
||||
|
|
@ -2659,7 +2639,7 @@ list that represents a doc string reference.
|
|||
;; byte-compile-noruntime-functions, in case we have an autoload
|
||||
;; of foo-func following an (eval-when-compile (require 'foo)).
|
||||
(unless (fboundp funsym)
|
||||
(push (byte-compile-strip-symbol-positions
|
||||
(push (macroexp-strip-symbol-positions
|
||||
(cons funsym (cons 'autoload (cdr (cdr form)))))
|
||||
byte-compile-function-environment))
|
||||
;; If an autoload occurs _before_ the first call to a function,
|
||||
|
|
@ -2676,7 +2656,7 @@ list that represents a doc string reference.
|
|||
(delq (assq funsym byte-compile-unresolved-functions)
|
||||
byte-compile-unresolved-functions)))))
|
||||
(if (stringp (nth 3 form))
|
||||
(prog1 (byte-compile-strip-symbol-positions form)
|
||||
(prog1 (macroexp-strip-symbol-positions form)
|
||||
(byte-compile-docstring-length-warn form))
|
||||
;; No doc string, so we can compile this as a normal form.
|
||||
(byte-compile-keep-pending form 'byte-compile-normal-call)))
|
||||
|
|
@ -2717,7 +2697,7 @@ list that represents a doc string reference.
|
|||
((symbolp (nth 2 form))
|
||||
(setcar (cddr form) (bare-symbol (nth 2 form))))
|
||||
(t (setcar (cddr form)
|
||||
(byte-compile-strip-symbol-positions (nth 2 form)))))
|
||||
(macroexp-strip-symbol-positions (nth 2 form)))))
|
||||
(setcar form (bare-symbol (car form)))
|
||||
(if (symbolp (nth 1 form))
|
||||
(setcar (cdr form) (bare-symbol (nth 1 form))))
|
||||
|
|
@ -2800,7 +2780,7 @@ list that represents a doc string reference.
|
|||
(prog1 (byte-compile-keep-pending form)
|
||||
(apply 'make-obsolete
|
||||
(mapcar 'eval
|
||||
(byte-compile-strip-symbol-positions (cdr form))))))
|
||||
(macroexp-strip-symbol-positions (cdr form))))))
|
||||
|
||||
;; This handler is not necessary, but it makes the output from dont-compile
|
||||
;; and similar macros cleaner.
|
||||
|
|
@ -2926,13 +2906,15 @@ not to take responsibility for the actual compilation of the code."
|
|||
(if (not (stringp (documentation code t))) -1 4)))
|
||||
(when byte-native-compiling
|
||||
;; Spill output for the native compiler here.
|
||||
(push (if macro
|
||||
(make-byte-to-native-top-level
|
||||
:form `(defalias ',name '(macro . ,code) nil)
|
||||
:lexical lexical-binding)
|
||||
(make-byte-to-native-func-def :name name
|
||||
:byte-func code))
|
||||
byte-to-native-top-level-forms))
|
||||
(push
|
||||
(macroexp-strip-symbol-positions
|
||||
(if macro
|
||||
(make-byte-to-native-top-level
|
||||
:form `(defalias ',name '(macro . ,code) nil)
|
||||
:lexical lexical-binding)
|
||||
(make-byte-to-native-func-def :name name
|
||||
:byte-func code)))
|
||||
byte-to-native-top-level-forms))
|
||||
;; Output the form by hand, that's much simpler than having
|
||||
;; b-c-output-file-form analyze the defalias.
|
||||
(byte-compile-output-docform
|
||||
|
|
@ -3020,37 +3002,40 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
|||
(macro (eq (car-safe fun) 'macro)))
|
||||
(if macro
|
||||
(setq fun (cdr fun)))
|
||||
(cond
|
||||
;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
|
||||
;; compile something invalid. So let's tune down the complaint from an
|
||||
;; error to a simple message for the known case where signaling an error
|
||||
;; causes problems.
|
||||
((byte-code-function-p fun)
|
||||
(message "Function %s is already compiled"
|
||||
(if (symbolp form) form "provided"))
|
||||
fun)
|
||||
(t
|
||||
(let (final-eval)
|
||||
(when (or (symbolp form) (eq (car-safe fun) 'closure))
|
||||
;; `fun' is a function *value*, so try to recover its corresponding
|
||||
;; source code.
|
||||
(setq lexical-binding (eq (car fun) 'closure))
|
||||
(setq fun (byte-compile--reify-function fun))
|
||||
(setq final-eval t))
|
||||
;; Expand macros.
|
||||
(setq fun (byte-compile-preprocess fun))
|
||||
(setq fun (byte-compile-top-level fun nil 'eval))
|
||||
(if (symbolp form)
|
||||
;; byte-compile-top-level returns an *expression* equivalent to the
|
||||
;; `fun' expression, so we need to evaluate it, tho normally
|
||||
;; this is not needed because the expression is just a constant
|
||||
;; byte-code object, which is self-evaluating.
|
||||
(setq fun (eval fun t)))
|
||||
(if final-eval
|
||||
(setq fun (eval fun t)))
|
||||
(if macro (push 'macro fun))
|
||||
(if (symbolp form) (fset form fun))
|
||||
fun)))))))
|
||||
(prog1
|
||||
(cond
|
||||
;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
|
||||
;; compile something invalid. So let's tune down the complaint from an
|
||||
;; error to a simple message for the known case where signaling an error
|
||||
;; causes problems.
|
||||
((byte-code-function-p fun)
|
||||
(message "Function %s is already compiled"
|
||||
(if (symbolp form) form "provided"))
|
||||
fun)
|
||||
(t
|
||||
(let (final-eval)
|
||||
(when (or (symbolp form) (eq (car-safe fun) 'closure))
|
||||
;; `fun' is a function *value*, so try to recover its corresponding
|
||||
;; source code.
|
||||
(setq lexical-binding (eq (car fun) 'closure))
|
||||
(setq fun (byte-compile--reify-function fun))
|
||||
(setq final-eval t))
|
||||
;; Expand macros.
|
||||
(setq fun (byte-compile-preprocess fun))
|
||||
(setq fun (byte-compile-top-level fun nil 'eval))
|
||||
(if (symbolp form)
|
||||
;; byte-compile-top-level returns an *expression* equivalent to the
|
||||
;; `fun' expression, so we need to evaluate it, tho normally
|
||||
;; this is not needed because the expression is just a constant
|
||||
;; byte-code object, which is self-evaluating.
|
||||
(setq fun (eval fun t)))
|
||||
(if final-eval
|
||||
(setq fun (eval fun t)))
|
||||
(if macro (push 'macro fun))
|
||||
(if (symbolp form) (fset form fun))
|
||||
fun)))
|
||||
(setq byte-to-native-top-level-forms
|
||||
(macroexp-strip-symbol-positions byte-to-native-top-level-forms)))))))
|
||||
|
||||
(defun byte-compile-sexp (sexp)
|
||||
"Compile and return SEXP."
|
||||
|
|
@ -3197,8 +3182,8 @@ for symbols generated by the byte compiler itself."
|
|||
;; which may include "calls" to
|
||||
;; internal-make-closure (Bug#29988).
|
||||
lexical-binding)
|
||||
(setq int (byte-compile-strip-symbol-positions `(interactive ,newform)))
|
||||
(setq int (byte-compile-strip-symbol-positions int)))))
|
||||
(setq int (macroexp-strip-symbol-positions `(interactive ,newform)))
|
||||
(setq int (macroexp-strip-symbol-positions int)))))
|
||||
((cdr int) ; Invalid (interactive . something).
|
||||
(byte-compile-warn-x int "malformed interactive spec: %s"
|
||||
int))))
|
||||
|
|
@ -3213,7 +3198,7 @@ for symbols generated by the byte compiler itself."
|
|||
(byte-compile-make-lambda-lexenv
|
||||
arglistvars))
|
||||
reserved-csts))
|
||||
(bare-arglist (byte-compile-strip-symbol-positions arglist)))
|
||||
(bare-arglist (macroexp-strip-symbol-positions arglist)))
|
||||
;; Build the actual byte-coded function.
|
||||
(cl-assert (eq 'byte-code (car-safe compiled)))
|
||||
(let ((out
|
||||
|
|
@ -3237,7 +3222,7 @@ for symbols generated by the byte compiler itself."
|
|||
;; We have some command modes, so use the vector form.
|
||||
(command-modes
|
||||
(list (vector (nth 1 int)
|
||||
(byte-compile-strip-symbol-positions
|
||||
(macroexp-strip-symbol-positions
|
||||
command-modes))))
|
||||
;; No command modes, use the simple form with just the
|
||||
;; interactive spec.
|
||||
|
|
@ -3785,7 +3770,7 @@ assignment (i.e. `setq')."
|
|||
(byte-compile-out
|
||||
'byte-constant
|
||||
(byte-compile-get-constant
|
||||
(byte-compile-strip-symbol-positions const))))
|
||||
(macroexp-strip-symbol-positions const))))
|
||||
|
||||
;; Compile those primitive ordinary functions
|
||||
;; which have special byte codes just for speed.
|
||||
|
|
@ -4619,7 +4604,7 @@ Return (TAIL VAR TEST CASES), where:
|
|||
|
||||
(dolist (case cases)
|
||||
(setq tag (byte-compile-make-tag)
|
||||
test-objects (byte-compile-strip-symbol-positions (car case))
|
||||
test-objects (macroexp-strip-symbol-positions (car case))
|
||||
body (cdr case))
|
||||
(byte-compile-out-tag tag)
|
||||
(dolist (value test-objects)
|
||||
|
|
@ -5265,7 +5250,7 @@ binding slots have been popped."
|
|||
(when (null form)
|
||||
(byte-compile-warn-x form "Uneven number of key bindings in %S" form))
|
||||
(push (pop form) result))
|
||||
(byte-compile-strip-symbol-positions orig-form)))
|
||||
(macroexp-strip-symbol-positions orig-form)))
|
||||
|
||||
(put 'define-keymap--define 'byte-hunk-handler
|
||||
#'byte-compile-define-keymap--define)
|
||||
|
|
@ -5332,9 +5317,9 @@ OP and OPERAND are as passed to `byte-compile-out'."
|
|||
;;; call tree stuff
|
||||
|
||||
(defun byte-compile-annotate-call-tree (form)
|
||||
(let ((current-form (byte-compile-strip-symbol-positions
|
||||
(let ((current-form (macroexp-strip-symbol-positions
|
||||
byte-compile-current-form))
|
||||
(bare-car-form (byte-compile-strip-symbol-positions (car form)))
|
||||
(bare-car-form (macroexp-strip-symbol-positions (car form)))
|
||||
entry)
|
||||
;; annotate the current call
|
||||
(if (setq entry (assq bare-car-form byte-compile-call-tree))
|
||||
|
|
@ -5552,8 +5537,10 @@ already up-to-date."
|
|||
(or (not (file-exists-p dest))
|
||||
(file-newer-than-file-p source dest))))
|
||||
(if (null (batch-byte-compile-file (car command-line-args-left)))
|
||||
(setq error t))))
|
||||
(setq error t))))
|
||||
(setq command-line-args-left (cdr command-line-args-left)))
|
||||
(setq byte-to-native-top-level-forms
|
||||
(macroexp-strip-symbol-positions byte-to-native-top-level-forms))
|
||||
(kill-emacs (if error 1 0))))
|
||||
|
||||
(defun batch-byte-compile-file (file)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue