;;; bytecomp.el --- compilation of Lisp code into byte code
-;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002
+;; Copyright (C) 1985,86,87,92,94,1998,2000,01,02,03,2004
;; Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Maintainer: FSF
;; Keywords: lisp
-;;; This version incorporates changes up to version 2.10 of the
-;;; Zawinski-Furuseth compiler.
-(defconst byte-compile-version "$Revision: 2.120 $")
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; User customization variables:
;;
;; byte-compile-verbose Whether to report the function currently being
-;; compiled in the minibuffer;
+;; compiled in the echo area;
;; byte-optimize Whether to do optimizations; this may be
;; t, nil, 'source, or 'byte;
;; byte-optimize-log Whether to report (in excruciating detail)
;; finding unused functions, as well as simple
;; performance metering.
;; byte-compile-warnings List of warnings to issue, or t. May contain
-;; 'free-vars (references to variables not in the
-;; current lexical scope)
-;; 'unresolved (calls to unknown functions)
-;; 'callargs (lambda calls with args that don't
-;; match the lambda's definition)
-;; 'redefine (function cell redefined from
-;; a macro to a lambda or vice versa,
-;; or redefined to take other args)
-;; 'obsolete (obsolete variables and functions)
-;; 'noruntime (calls to functions only defined
-;; within `eval-when-compile')
+;; `free-vars' (references to variables not in the
+;; current lexical scope)
+;; `unresolved' (calls to unknown functions)
+;; `callargs' (lambda calls with args that don't
+;; match the lambda's definition)
+;; `redefine' (function cell redefined from
+;; a macro to a lambda or vice versa,
+;; or redefined to take other args)
+;; `obsolete' (obsolete variables and functions)
+;; `noruntime' (calls to functions only defined
+;; within `eval-when-compile')
;; byte-compile-compatibility Whether the compiler should
;; generate .elc files which can be loaded into
;; generic emacs 18.
;; (baz 0))
;;
;; o It is possible to open-code a function in the same file it is defined
-;; in without having to load that file before compiling it. the
+;; in without having to load that file before compiling it. The
;; byte-compiler has been modified to remember function definitions in
;; the compilation environment in the same way that it remembers macro
;; definitions.
(or (fboundp 'defsubst)
;; This really ought to be loaded already!
- (load-library "byte-run"))
+ (load "byte-run"))
;; The feature of compiling in a specific target Emacs version
;; has been turned off because compile time options are a bad idea.
:type 'boolean)
(defcustom byte-compile-compatibility nil
- "*Non-nil means generate output that can run in Emacs 18."
+ "*Non-nil means generate output that can run in Emacs 18.
+This only means that it can run in principle, if it doesn't require
+facilities that have been added more recently."
:group 'bytecomp
:type 'boolean)
(const callargs) (const redefine)
(const obsolete) (const noruntime) (const cl-functions))))
+(defvar byte-compile-not-obsolete-var nil
+ "If non-nil, this is a variable that shouldn't be reported as obsolete.")
+
(defcustom byte-compile-generate-call-tree nil
"*Non-nil means collect call-graph information when compiling.
This records functions were called and from where.
(defvar byte-compile-bound-variables nil
"List of variables bound in the context of the current form.
This list lives partly on the stack.")
+(defvar byte-compile-const-variables nil
+ "List of variables declared as constants during compilation of this file.")
(defvar byte-compile-free-references)
(defvar byte-compile-free-assignments)
Used for warnings when the function is not known to be defined or is later
defined with incorrect args.")
+(defvar byte-compile-noruntime-functions nil
+ "Alist of functions called that may not be defined when the compiled code is run.
+Used for warnings about calling a function that is defined during compilation
+but won't necessarily be defined when the compiled file is loaded.")
+
(defvar byte-compile-tag-number 0)
(defvar byte-compile-output nil
"Alist describing contents to put in byte code string.
(let ((pc 0) ; Program counter
op off ; Operation & offset
(bytes '()) ; Put the output bytes here
- (patchlist nil) ; List of tags and goto's to patch
- rest rel tmp)
+ (patchlist nil)) ; List of tags and goto's to patch
(while lap
(setq op (car (car lap))
off (cdr (car lap)))
(defun byte-compile-eval (form)
"Eval FORM and mark the functions defined therein.
-Each function's symbol gets marked with the `byte-compile-noruntime' property."
+Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((hist-orig load-history)
(hist-nil-orig current-load-list))
(prog1 (eval form)
(cond
((symbolp s)
(unless (memq s old-autoloads)
- (put s 'byte-compile-noruntime t)))
+ (push s byte-compile-noruntime-functions)))
((and (consp s) (eq t (car s)))
- (push s old-autoloads))
+ (push (cdr s) old-autoloads))
((and (consp s) (eq 'autoload (car s)))
- (put (cdr s) 'byte-compile-noruntime t)))))))
+ (push (cdr s) byte-compile-noruntime-functions)))))))
;; Go through current-load-list for the locally defined funs.
(let (old-autoloads)
(while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
(let ((s (pop hist-nil-new)))
(when (and (symbolp s) (not (memq s old-autoloads)))
- (put s 'byte-compile-noruntime t))
+ (push s byte-compile-noruntime-functions))
(when (and (consp s) (eq t (car s)))
- (push s old-autoloads))))))))))
+ (push (cdr s) old-autoloads))))))))))
(defun byte-compile-eval-before-compile (form)
"Evaluate FORM for `eval-and-compile'."
(when (or (and byte-compile-current-file
(not (equal byte-compile-current-file
byte-compile-last-logged-file)))
- (and byte-compile-last-warned-form
+ (and byte-compile-current-form
(not (eq byte-compile-current-form
byte-compile-last-warned-form))))
(insert (format "\nIn %s:\n" form)))
(and (not (equal byte-compile-current-file byte-compile-last-logged-file))
(not noninteractive)
(save-excursion
- (byte-goto-log-buffer)
+ (set-buffer (get-buffer-create "*Compile-Log*"))
(goto-char (point-max))
(let* ((dir (and byte-compile-current-file
(file-name-directory byte-compile-current-file)))
(setq default-directory dir)
(unless was-same
(insert (format "Entering directory `%s'\n" default-directory))))
- (setq byte-compile-last-logged-file byte-compile-current-file)
+ (setq byte-compile-last-logged-file byte-compile-current-file
+ byte-compile-last-warned-form nil)
+ ;; Do this after setting default-directory.
+ (unless (eq major-mode 'compilation-mode)
+ (compilation-mode))
pt))))
;; Log a message STRING in *Compile-Log*.
;; Also log the current function and file if not already done.
(defun byte-compile-log-warning (string &optional fill level)
(let ((warning-prefix-function 'byte-compile-warning-prefix)
- (warning-group-format "")
+ (warning-type-format "")
(warning-fill-prefix (if fill " ")))
(display-warning 'bytecomp string level "*Compile-Log*")))
"requires"
"accepts only")
(byte-compile-arglist-signature-string sig))))
+ (byte-compile-format-warn form)
;; Check to see if the function will be available at runtime
;; and/or remember its arity if it's unknown.
(or (and (or sig (fboundp (car form))) ; might be a subr or autoload.
- (not (get (car form) 'byte-compile-noruntime)))
+ (not (memq (car form) byte-compile-noruntime-functions)))
(eq (car form) byte-compile-current-form) ; ## this doesn't work
; with recursion.
;; It's a currently-undefined function.
(cons (list (car form) n)
byte-compile-unresolved-functions)))))))
+(defun byte-compile-format-warn (form)
+ "Warn if FORM is `format'-like with inconsistent args.
+Applies if head of FORM is a symbol with non-nil property
+`byte-compile-format-like' and first arg is a constant string.
+Then check the number of format fields matches the number of
+extra args."
+ (when (and (symbolp (car form))
+ (stringp (nth 1 form))
+ (get (car form) 'byte-compile-format-like))
+ (let ((nfields (with-temp-buffer
+ (insert (nth 1 form))
+ (goto-char 1)
+ (let ((n 0))
+ (while (re-search-forward "%." nil t)
+ (unless (eq ?% (char-after (1+ (match-beginning 0))))
+ (setq n (1+ n))))
+ n)))
+ (nargs (- (length form) 2)))
+ (unless (= nargs nfields)
+ (byte-compile-warn
+ "`%s' called with %d args to fill %d format field(s)" (car form)
+ nargs nfields)))))
+
+(dolist (elt '(format message error))
+ (put elt 'byte-compile-format-like t))
+
;; Warn if the function or macro is being redefined with a different
;; number of arguments.
(defun byte-compile-arglist-warn (form macrop)
(let ((func (car-safe form)))
(if (and byte-compile-cl-functions
(memq func byte-compile-cl-functions)
- ;; Aliases which won't have been expended at this point.
+ ;; Aliases which won't have been expanded at this point.
;; These aren't all aliases of subrs, so not trivial to
;; avoid hardwiring the list.
(not (memq func
;; These would sometimes be warned about
;; but such warnings are never useful,
;; so don't warn about them.
- macroexpand cl-macroexpand-all cl-compiling-file))))
+ macroexpand cl-macroexpand-all
+ cl-compiling-file)))
+ ;; Avoid warnings for things which are safe because they
+ ;; have suitable compiler macros, but those aren't
+ ;; expanded at this stage. There should probably be more
+ ;; here than caaar and friends.
+ (not (and (eq (get func 'byte-compile)
+ 'cl-byte-compile-compiler-macro)
+ (string-match "\\`c[ad]+r\\'" (symbol-name func)))))
(byte-compile-warn "Function `%s' from cl package called at runtime"
func)))
form)
nil)
\f
-(defsubst byte-compile-const-symbol-p (symbol)
+(defsubst byte-compile-const-symbol-p (symbol &optional any-value)
+ "Non-nil if SYMBOL is constant.
+If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
+symbol itself."
(or (memq symbol '(nil t))
- (keywordp symbol)))
+ (keywordp symbol)
+ (if any-value (memq symbol byte-compile-const-variables))))
(defmacro byte-compile-constp (form)
"Return non-nil if FORM is a constant."
(copy-alist byte-compile-initial-macro-environment))
(byte-compile-function-environment nil)
(byte-compile-bound-variables nil)
+ (byte-compile-const-variables nil)
(byte-compile-free-references nil)
(byte-compile-free-assignments nil)
;;
(save-some-buffers)
(force-mode-line-update))
(save-current-buffer
- (byte-goto-log-buffer)
- (setq default-directory directory)
+ (set-buffer (get-buffer-create "*Compile-Log*"))
+ (setq default-directory (expand-file-name directory))
+ ;; compilation-mode copies value of default-directory.
+ (unless (eq major-mode 'compilation-mode)
+ (compilation-mode))
(let ((directories (list (expand-file-name directory)))
(default-directory default-directory)
(skip-count 0)
source dest)
(dolist (file files)
(setq source (expand-file-name file directory))
- (if (and (not (member file '("." ".." "RCS" "CVS")))
+ (if (and (not (member file '("RCS" "CVS")))
+ (not (eq ?\. (aref file 0)))
(file-directory-p source)
(not (file-symlink-p source)))
;; This file is a subdirectory. Handle them differently.
;; 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-buffer-file-coding-system
- ;; can make the buffer unibyte when visiting this file.
+ ;; 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...,
;; compile this file.
(if (with-current-buffer input-buffer no-byte-compile)
(progn
- (message "%s not compiled because of `no-byte-compile: %s'"
- (file-relative-name filename)
- (with-current-buffer input-buffer no-byte-compile))
- (if (file-exists-p target-file)
- (condition-case nil (delete-file target-file) (error nil)))
+ ;; (message "%s not compiled because of `no-byte-compile: %s'"
+ ;; (file-relative-name filename)
+ ;; (with-current-buffer input-buffer no-byte-compile))
+ (when (file-exists-p target-file)
+ (message "%s deleted because of `no-byte-compile: %s'"
+ (file-relative-name 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
;;;###autoload
(defun compile-defun (&optional arg)
"Compile and evaluate the current top-level form.
-Print the result in the minibuffer.
+Print the result in the echo area.
With argument, insert value in current buffer after the form."
(interactive "P")
(save-excursion
(byte-compile-file-form form)))
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
+ ;; Make warnings about unresolved functions
+ ;; give the end of the file as their position.
+ (setq byte-compile-last-position (point-max))
(byte-compile-warn-about-unresolved-functions)
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have
outbuffer))
(defun byte-compile-fix-header (filename inbuffer outbuffer)
- (save-excursion
- (set-buffer outbuffer)
+ (with-current-buffer outbuffer
;; See if the buffer has any multibyte characters.
(when (< (point-max) (position-bytes (point-max)))
(when (byte-compile-version-cond byte-compile-compatibility)
" on "
(current-time-string) "\n;;; from file " filename "\n")
(insert ";;; in Emacs version " emacs-version "\n")
- (insert ";;; with bytecomp version "
- (progn (string-match "[0-9.]+" byte-compile-version)
- (match-string 0 byte-compile-version))
- "\n;;; "
+ (insert ";;; "
(cond
((eq byte-optimize 'source) "with source-level optimization only")
((eq byte-optimize 'byte) "with byte-level optimization only")
(prin1 form outbuffer)
nil)))
+(defvar print-gensym-alist) ;Used before print-circle existed.
+
(defun byte-compile-output-docform (preface name info form specindex quoted)
"Print a form with a doc string. INFO is (prefix doc-index postfix).
If PREFACE and NAME are non-nil, print them too,
;; print-gensym-alist not to be cleared
;; between calls to print functions.
(print-gensym '(t))
- ;; print-gensym-alist was used before print-circle existed.
- print-gensym-alist
+ print-gensym-alist ; was used before print-circle existed.
(print-continuous-numbering t)
print-number-table
(index 0))
(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(defun byte-compile-file-form-defsubst (form)
- (cond ((assq (nth 1 form) byte-compile-unresolved-functions)
- (setq byte-compile-current-form (nth 1 form))
- (byte-compile-warn "defsubst %s was used before it was defined"
- (nth 1 form))))
+ (when (assq (nth 1 form) byte-compile-unresolved-functions)
+ (setq byte-compile-current-form (nth 1 form))
+ (byte-compile-warn "defsubst %s was used before it was defined"
+ (nth 1 form)))
(byte-compile-file-form
(macroexpand form byte-compile-macro-environment))
;; Return nil so the form is not output twice.
;; Since there is no doc string, we can compile this as a normal form,
;; and not do a file-boundary.
(byte-compile-keep-pending form)
- (if (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons (nth 1 form) byte-compile-bound-variables)))
+ (when (memq 'free-vars byte-compile-warnings)
+ (push (nth 1 form) byte-compile-bound-variables)
+ (if (eq (car form) 'defconst)
+ (push (nth 1 form) byte-compile-const-variables)))
(cond ((consp (nth 2 form))
(setq form (copy-sequence form))
(setcar (cdr (cdr form))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-custom-declare-variable)
(defun byte-compile-file-form-custom-declare-variable (form)
- (if (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
+ (when (memq 'free-vars byte-compile-warnings)
+ (push (nth 1 (nth 1 form)) byte-compile-bound-variables))
(let ((tail (nthcdr 4 form)))
(while tail
;; If there are any (function (lambda ...)) expressions, compile
(when (symbolp arg)
(byte-compile-set-symbol-position arg))
(cond ((or (not (symbolp arg))
- (keywordp arg)
- (memq arg '(t nil)))
+ (byte-compile-const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
((eq arg '&rest)
(unless (cdr list)
(if (cdr body)
(setq body (cdr body))))))
(int (assq 'interactive body)))
- (cond (int
- (byte-compile-set-symbol-position 'interactive)
- ;; Skip (interactive) if it is in front (the most usual location).
- (if (eq int (car body))
- (setq body (cdr body)))
- (cond ((consp (cdr int))
- (if (cdr (cdr int))
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int)))
- ;; If the interactive spec is a call to `list',
- ;; don't compile it, because `call-interactively'
- ;; looks at the args of `list'.
- (let ((form (nth 1 int)))
- (while (memq (car-safe form) '(let let* progn save-excursion))
- (while (consp (cdr form))
- (setq form (cdr form)))
- (setq form (car form)))
- (or (eq (car-safe form) 'list)
- (setq int (list 'interactive
- (byte-compile-top-level (nth 1 int)))))))
- ((cdr int)
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int))))))
+ ;; Process the interactive spec.
+ (when int
+ (byte-compile-set-symbol-position 'interactive)
+ ;; Skip (interactive) if it is in front (the most usual location).
+ (if (eq int (car body))
+ (setq body (cdr body)))
+ (cond ((consp (cdr int))
+ (if (cdr (cdr int))
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))
+ ;; If the interactive spec is a call to `list', don't
+ ;; compile it, because `call-interactively' looks at the
+ ;; args of `list'. Actually, compile it to get warnings,
+ ;; but don't use the result.
+ (let ((form (nth 1 int)))
+ (while (memq (car-safe form) '(let let* progn save-excursion))
+ (while (consp (cdr form))
+ (setq form (cdr form)))
+ (setq form (car form)))
+ (if (eq (car-safe form) 'list)
+ (byte-compile-top-level (nth 1 int))
+ (setq int (list 'interactive
+ (byte-compile-top-level (nth 1 int)))))))
+ ((cdr int)
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))))
+ ;; Process the body.
(let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
+ ;; Build the actual byte-coded function.
(if (and (eq 'byte-code (car-safe compiled))
(not (byte-compile-version-cond
byte-compile-compatibility)))
(defun byte-compile-variable-ref (base-op var)
(when (symbolp var)
(byte-compile-set-symbol-position var))
- (if (or (not (symbolp var)) (byte-compile-const-symbol-p var))
- (byte-compile-warn (if (eq base-op 'byte-varbind)
- "attempt to let-bind %s %s"
- "variable reference to %s %s")
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var))
+ (if (or (not (symbolp var))
+ (byte-compile-const-symbol-p var (not (eq base-op 'byte-varref))))
+ (byte-compile-warn
+ (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s %s")
+ ((eq base-op 'byte-varset) "variable assignment to %s %s")
+ (t "variable reference to %s %s"))
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
- (memq 'obsolete byte-compile-warnings))
+ (memq 'obsolete byte-compile-warnings)
+ (not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
(byte-compile-warn "%s is an obsolete variable%s; %s" var
(format "use %s instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind)
- (setq byte-compile-bound-variables
- (cons var byte-compile-bound-variables))
+ (push var byte-compile-bound-variables)
(or (boundp var)
(memq var byte-compile-bound-variables)
(if (eq base-op 'byte-varset)
(or (memq var byte-compile-free-assignments)
(progn
(byte-compile-warn "assignment to free variable %s" var)
- (setq byte-compile-free-assignments
- (cons var byte-compile-free-assignments))))
+ (push var byte-compile-free-assignments)))
(or (memq var byte-compile-free-references)
(progn
(byte-compile-warn "reference to free variable %s" var)
- (setq byte-compile-free-references
- (cons var byte-compile-free-references)))))))))
+ (push var byte-compile-free-references))))))))
(let ((tmp (assq var byte-compile-variables)))
- (or tmp
- (setq tmp (list var)
- byte-compile-variables (cons tmp byte-compile-variables)))
+ (unless tmp
+ (setq tmp (list var))
+ (push tmp byte-compile-variables))
(byte-compile-out base-op tmp)))
(defmacro byte-compile-get-constant (const)
`(or (if (stringp ,const)
- (assoc ,const byte-compile-constants)
+ (assoc-default ,const byte-compile-constants
+ 'equal-including-properties nil)
(assq ,const byte-compile-constants))
(car (setq byte-compile-constants
(cons (list ,const) byte-compile-constants)))))
;; If function is a symbol, then the variable "byte-SYMBOL" must name
;; the opcode to be used. If function is a list, the first element
;; is the function and the second element is the bytecode-symbol.
+ ;; The second element may be nil, meaning there is no opcode.
;; COMPILE-HANDLER is the function to use to compile this byte-op, or
;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
;; If it is nil, then the handler is "byte-compile-SYMBOL."
(setq args (cdr args))
(or args (setq args '(0)
opcode (get '+ 'byte-opcode)))
- (while args
- (byte-compile-form (car args))
- (byte-compile-out opcode 0)
- (setq args (cdr args))))
+ (dolist (arg args)
+ (byte-compile-form arg)
+ (byte-compile-out opcode 0)))
(byte-compile-constant (eval form))))
\f
(if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
,tag))
+(defmacro byte-compile-maybe-guarded (condition &rest body)
+ "Execute forms in BODY, potentially guarded by CONDITION.
+CONDITION is the test in an `if' form or in a `cond' clause.
+BODY is to compile the first arm of the if or the body of the
+cond clause. If CONDITION is of the form `(foundp 'foo)'
+or `(boundp 'foo)', the relevant warnings from BODY about foo
+being undefined will be suppressed."
+ (declare (indent 1) (debug t))
+ `(let* ((fbound
+ (if (eq 'fboundp (car-safe ,condition))
+ (and (eq 'quote (car-safe (nth 1 ,condition)))
+ ;; Ignore if the symbol is already on the
+ ;; unresolved list.
+ (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol
+ byte-compile-unresolved-functions))
+ (nth 1 (nth 1 ,condition)))))
+ (bound (if (or (eq 'boundp (car-safe ,condition))
+ (eq 'default-boundp (car-safe ,condition)))
+ (and (eq 'quote (car-safe (nth 1 ,condition)))
+ (nth 1 (nth 1 ,condition)))))
+ ;; Maybe add to the bound list.
+ (byte-compile-bound-variables
+ (if bound
+ (cons bound byte-compile-bound-variables)
+ byte-compile-bound-variables)))
+ (progn ,@body)
+ ;; Maybe remove the function symbol from the unresolved list.
+ (if fbound
+ (setq byte-compile-unresolved-functions
+ (delq (assq fbound byte-compile-unresolved-functions)
+ byte-compile-unresolved-functions)))))
+
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
;; Check whether we have `(if (fboundp ...' or `(if (boundp ...'
;; and avoid warnings about the relevent symbols in the consequent.
- (let* ((clause (nth 1 form))
- (fbound (if (eq 'fboundp (car-safe clause))
- (and (eq 'quote (car-safe (nth 1 clause)))
- ;; Ignore if the symbol is already on the
- ;; unresolved list.
- (not (assq
- (nth 1 (nth 1 clause)) ; the relevant symbol
- byte-compile-unresolved-functions))
- (nth 1 (nth 1 clause)))))
- (bound (if (eq 'boundp (car-safe clause))
- (and (eq 'quote (car-safe (nth 1 clause)))
- (nth 1 (nth 1 clause)))))
- (donetag (byte-compile-make-tag)))
+ (let ((clause (nth 1 form))
+ (donetag (byte-compile-make-tag)))
(if (null (nthcdr 3 form))
;; No else-forms
(progn
(byte-compile-goto-if nil for-effect donetag)
- ;; Maybe add to the bound list.
- (let ((byte-compile-bound-variables
- (if bound
- (cons bound byte-compile-bound-variables)
- byte-compile-bound-variables)))
+ (byte-compile-maybe-guarded clause
(byte-compile-form (nth 2 form) for-effect))
- ;; Maybe remove the function symbol from the unresolved list.
- (if fbound
- (setq byte-compile-unresolved-functions
- (delq (assq fbound byte-compile-unresolved-functions)
- byte-compile-unresolved-functions)))
(byte-compile-out-tag donetag))
(let ((elsetag (byte-compile-make-tag)))
(byte-compile-goto 'byte-goto-if-nil elsetag)
- ;; As above for the first form.
- (let ((byte-compile-bound-variables
- (if bound
- (cons bound byte-compile-bound-variables)
- byte-compile-bound-variables)))
- (byte-compile-form (nth 2 form) for-effect))
- (if fbound
- (setq byte-compile-unresolved-functions
- (delq (assq fbound byte-compile-unresolved-functions)
- byte-compile-unresolved-functions)))
+ (byte-compile-maybe-guarded clause
+ (byte-compile-form (nth 2 form) for-effect))
(byte-compile-goto 'byte-goto donetag)
(byte-compile-out-tag elsetag)
(byte-compile-body (cdr (cdr (cdr form))) for-effect)
(if (null (cdr clause))
;; First clause is a singleton.
(byte-compile-goto-if t for-effect donetag)
- (setq nexttag (byte-compile-make-tag))
- (byte-compile-goto 'byte-goto-if-nil nexttag)
- (byte-compile-body (cdr clause) for-effect)
- (byte-compile-goto 'byte-goto donetag)
- (byte-compile-out-tag nexttag)))))
+ (setq nexttag (byte-compile-make-tag))
+ (byte-compile-goto 'byte-goto-if-nil nexttag)
+ (byte-compile-maybe-guarded (car clause)
+ (byte-compile-body (cdr clause) for-effect))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag nexttag)))))
;; Last clause
- (and (cdr clause) (not (eq (car clause) t))
- (progn (byte-compile-form (car clause))
- (byte-compile-goto-if nil for-effect donetag)
- (setq clause (cdr clause))))
- (byte-compile-body-do-effect clause)
+ (let ((guard (car clause)))
+ (and (cdr clause) (not (eq guard t))
+ (progn (byte-compile-form guard)
+ (byte-compile-goto-if nil for-effect donetag)
+ (setq clause (cdr clause))))
+ (byte-compile-maybe-guarded guard
+ (byte-compile-body-do-effect clause)))
(byte-compile-out-tag donetag)))
(defun byte-compile-and (form)
(defun byte-compile-let (form)
;; First compute the binding values in the old scope.
(let ((varlist (car (cdr form))))
- (while varlist
- (if (consp (car varlist))
- (byte-compile-form (car (cdr (car varlist))))
- (byte-compile-push-constant nil))
- (setq varlist (cdr varlist))))
+ (dolist (var varlist)
+ (if (consp var)
+ (byte-compile-form (car (cdr var)))
+ (byte-compile-push-constant nil))))
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(varlist (reverse (car (cdr form)))))
- (while varlist
- (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist))
- (car (car varlist))
- (car varlist)))
- (setq varlist (cdr varlist)))
+ (dolist (var varlist)
+ (byte-compile-variable-ref 'byte-varbind (if (consp var) (car var) var)))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(defun byte-compile-let* (form)
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(varlist (copy-sequence (car (cdr form)))))
- (while varlist
- (if (atom (car varlist))
+ (dolist (var varlist)
+ (if (atom var)
(byte-compile-push-constant nil)
- (byte-compile-form (car (cdr (car varlist))))
- (setcar varlist (car (car varlist))))
- (byte-compile-variable-ref 'byte-varbind (car varlist))
- (setq varlist (cdr varlist)))
+ (byte-compile-form (car (cdr var)))
+ (setq var (car var)))
+ (byte-compile-variable-ref 'byte-varbind var))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(defun byte-compile-track-mouse (form)
(byte-compile-form
- (list
- 'funcall
- (list 'quote
- (list 'lambda nil
- (cons 'track-mouse
- (byte-compile-top-level-body (cdr form))))))))
+ `(funcall '(lambda nil
+ (track-mouse ,@(byte-compile-top-level-body (cdr form)))))))
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
(byte-compile-out 'byte-temp-output-buffer-setup 0)
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-temp-output-buffer-show 0))
-
\f
;;; top-level forms elsewhere
(byte-compile-set-symbol-position (car form))
(byte-compile-set-symbol-position 'defun)
(error "defun name must be a symbol, not %s" (car form)))
- (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
- (list 'fset (list 'quote (nth 1 form))
- (byte-compile-byte-code-maker
- (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
- (byte-compile-discard)
+ (if (byte-compile-version-cond byte-compile-compatibility)
+ (progn
+ (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
+ (list 'fset
+ (list 'quote (nth 1 form))
+ (byte-compile-byte-code-maker
+ (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
+ (byte-compile-discard))
+ ;; We prefer to generate a defalias form so it will record the function
+ ;; definition just like interpreting a defun.
+ (byte-compile-form
+ (list 'defalias
+ (list 'quote (nth 1 form))
+ (byte-compile-byte-code-maker
+ (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))
+ t))
(byte-compile-constant (nth 1 form)))
(defun byte-compile-defmacro (form)
(value (nth 2 form))
(string (nth 3 form)))
(byte-compile-set-symbol-position fun)
- (when (> (length form) 4)
- (byte-compile-warn
- "%s %s called with %d arguments, but accepts only %s"
- fun var (length (cdr form)) 3))
+ (when (or (> (length form) 4)
+ (and (eq fun 'defconst) (null (cddr form))))
+ (let ((ncall (length (cdr form))))
+ (byte-compile-warn
+ "%s called with %d argument%s, but %s %s"
+ fun ncall
+ (if (= 1 ncall) "" "s")
+ (if (< ncall 2) "requires" "accepts only")
+ "2-3")))
(when (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons var byte-compile-bound-variables)))
+ (push var byte-compile-bound-variables)
+ (if (eq fun 'defconst)
+ (push var byte-compile-const-variables)))
(byte-compile-body-do-effect
(list
;; Put the defined variable in this library's load-history entry
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cddr form) ; `value' provided
- (if (eq fun 'defconst)
- ;; `defconst' sets `var' unconditionally.
- (let ((tmp (make-symbol "defconst-tmp-var")))
- `(let ((,tmp ,value))
- (eval '(defconst ,var ,tmp))))
- ;; `defvar' sets `var' only when unbound.
- `(if (not (boundp ',var)) (setq ,var ,value))))
+ (let ((byte-compile-not-obsolete-var var))
+ (if (eq fun 'defconst)
+ ;; `defconst' sets `var' unconditionally.
+ (let ((tmp (make-symbol "defconst-tmp-var")))
+ `(funcall '(lambda (,tmp) (defconst ,var ,tmp))
+ ,value))
+ ;; `defvar' sets `var' only when unbound.
+ `(if (not (default-boundp ',var)) (setq-default ,var ,value))))
+ (when (eq fun 'defconst)
+ ;; This will signal an appropriate error at runtime.
+ `(eval ',form)))
`',var))))
(defun byte-compile-autoload (form)
(consp (cdr (nth 2 form)))
(symbolp (nth 1 (nth 2 form))))
(progn
- (byte-compile-defalias-warn (nth 1 (nth 1 form))
- (nth 1 (nth 2 form)))
+ (byte-compile-defalias-warn (nth 1 (nth 1 form)))
(setq byte-compile-function-environment
(cons (cons (nth 1 (nth 1 form))
(nth 1 (nth 2 form)))
;; Turn off warnings about prior calls to the function being defalias'd.
;; This could be smarter and compare those calls with
;; the function it is being aliased to.
-(defun byte-compile-defalias-warn (new alias)
+(defun byte-compile-defalias-warn (new)
(let ((calls (assq new byte-compile-unresolved-functions)))
(if calls
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions)))))
+
+(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
+(defun byte-compile-no-warnings (form)
+ (let (byte-compile-warnings)
+ (byte-compile-form (cadr form))))
\f
;;; tags
(setcdr (cdr tag) byte-compile-depth)))
(defun byte-compile-goto (opcode tag)
- (setq byte-compile-output (cons (cons opcode tag) byte-compile-output))
+ (push (cons opcode tag) byte-compile-output)
(setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
(1- byte-compile-depth)
byte-compile-depth))
(1- byte-compile-depth))))
(defun byte-compile-out (opcode offset)
- (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
+ (push (cons opcode offset) byte-compile-output)
(cond ((eq opcode 'byte-call)
(setq byte-compile-depth (- byte-compile-depth offset)))
((eq opcode 'byte-return)
\f
;;; report metering (see the hacks in bytecode.c)
+(defvar byte-code-meter)
(defun byte-compile-report-ops ()
- (defvar byte-code-meter)
(with-output-to-temp-buffer "*Meter*"
(set-buffer "*Meter*")
(let ((i 0) n op off)
(run-hooks 'bytecomp-load-hook)
+;;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a
;;; bytecomp.el ends here