;; The feature of compiling in a specific target Emacs version
;; has been turned off because compile time options are a bad idea.
-(defmacro byte-compile-single-version () nil)
-(defmacro byte-compile-version-cond (cond) cond)
-
-
(defgroup bytecomp nil
"Emacs Lisp byte-compiler."
:group 'lisp)
:type '(choice (const name) (const callers) (const calls)
(const calls+callers) (const nil)))
-(defvar byte-compile-debug t)
-(setq debug-on-error t)
-
+(defvar byte-compile-debug nil)
(defvar byte-compile-constants nil
"List of all constants encountered during compilation of this form.")
(defvar byte-compile-variables nil
but won't necessarily be defined when the compiled file is loaded.")
;; Variables for lexical binding
-(defvar byte-compile-lexical-environment nil
+(defvar byte-compile--lexical-environment nil
"The current lexical environment.")
(defvar byte-compile-tag-number 0)
(byte-defop 114 0 byte-save-current-buffer
"To make a binding to record the current buffer")
(byte-defop 115 0 byte-set-mark-OBSOLETE)
+(byte-defop 116 1 byte-interactive-p-OBSOLETE)
;; These ops are new to v19
(byte-defop 117 0 byte-forward-char)
(byte-defop 138 0 byte-save-excursion
"to make a binding to record the buffer, point and mark")
+(byte-defop 139 0 byte-save-window-excursion-OBSOLETE
+ "to make a binding to record entire window configuration")
(byte-defop 140 0 byte-save-restriction
"to make a binding to record the current buffer clipping restrictions")
(byte-defop 141 -1 byte-catch
;; an expression for the body, and a list of clauses.
(byte-defop 143 -2 byte-condition-case)
-;; For entry to with-output-to-temp-buffer.
-;; Takes, on stack, the buffer name.
-;; Binds standard-output and does some other things.
-;; Returns with temp buffer on the stack in place of buffer name.
-;; (byte-defop 144 0 byte-temp-output-buffer-setup)
-
-;; For exit from with-output-to-temp-buffer.
-;; Expects the temp buffer on the stack underneath value to return.
-;; Pops them both, then pushes the value back on.
-;; Unbinds standard-output and makes the temp buffer visible.
-;; (byte-defop 145 -1 byte-temp-output-buffer-show)
+(byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE)
+(byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE)
;; these ops are new to v19
(byte-defop 168 0 byte-integerp)
;; unused: 169-174
-
(byte-defop 175 nil byte-listN)
(byte-defop 176 nil byte-concatN)
(byte-defop 177 nil byte-insertN)
-(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte
-(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes
+(byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte.
+(byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes.
-;; if (following one byte & 0x80) == 0
+;; If (following one byte & 0x80) == 0
;; discard (following one byte & 0x7F) stack entries
;; else
;; discard (following one byte & 0x7F) stack entries _underneath_ TOS
(error "Non-symbolic opcode `%s'" op))
((eq op 'TAG)
(setcar off pc))
- ((null op)
- ;; a no-op added by `byte-compile-delay-out'
- (unless (zerop off)
- (error
- "Placeholder added by `byte-compile-delay-out' not filled in.")
- ))
(t
(setq opcode
(if (eq op 'byte-discardN-preserve-tos)
(cond ((memq op byte-goto-ops)
;; goto
(byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
- (push bytes patchlist))
+ (push bytes patchlist))
((or (and (consp off)
;; Variable or constant reference
(progn
(setq off (cdr off))
(eq op 'byte-constant)))
- (and (eq op 'byte-constant) ;; 'byte-closed-var
+ (and (eq op 'byte-constant)
(integerp off)))
;; constant ref
(if (< off byte-constant-limit)
bytes pc))))))
;;(if (not (= pc (length bytes)))
;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
-
- ;; Patch tag PCs into absolute jumps
+ ;; Patch tag PCs into absolute jumps.
(dolist (bytes-tail patchlist)
- (setq pc (caar bytes-tail)) ; Pick PC from goto's tag
+ (setq pc (caar bytes-tail)) ; Pick PC from goto's tag.
(setcar (cdr bytes-tail) (logand pc 255))
(setcar bytes-tail (lsh pc -8))
;; FIXME: Replace this by some workaround.
- (if (> (car bytes) 255) (error "Bytecode overflow")))
+ (if (> (car bytes-tail) 255) (error "Bytecode overflow")))
(apply 'unibyte-string (nreverse bytes))))
(let* ((funcp (get symbol 'byte-obsolete-info))
(obsolete (or funcp (get symbol 'byte-obsolete-variable)))
(instead (car obsolete))
- (asof (if funcp (nth 2 obsolete) (cdr obsolete))))
+ (asof (nth 2 obsolete)))
(unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
(byte-compile-warn "`%s' is an obsolete %s%s%s" symbol
(if funcp "function" "variable")
;; number of arguments.
(defun byte-compile-arglist-warn (form macrop)
(let* ((name (nth 1 form))
- (old (byte-compile-fdefinition name macrop)))
+ (old (byte-compile-fdefinition name macrop))
+ (initial (and macrop
+ (cdr (assq name
+ byte-compile-initial-macro-environment)))))
+ ;; Assumes an element of b-c-i-macro-env that is a symbol points
+ ;; to a defined function. (Bug#8646)
+ (and initial (symbolp initial)
+ (setq old (byte-compile-fdefinition initial nil)))
(if (and old (not (eq old t)))
(progn
(and (eq 'macro (car-safe old))
;; Dynamically bound in byte-compile-from-buffer.
;; NB also used in cl.el and cl-macs.el.
-(defvar byte-compile-outbuffer)
+(defvar byte-compile--outbuffer)
(defun byte-compile-from-buffer (inbuffer)
- (let (byte-compile-outbuffer
+ (let (byte-compile--outbuffer
(byte-compile-current-buffer inbuffer)
(byte-compile-read-position nil)
(byte-compile-last-position nil)
)
(byte-compile-close-variables
(with-current-buffer
- (setq byte-compile-outbuffer (get-buffer-create " *Compiler Output*"))
+ (setq byte-compile--outbuffer
+ (get-buffer-create " *Compiler Output*"))
(set-buffer-multibyte t)
(erase-buffer)
;; (emacs-lisp-mode)
(with-current-buffer inbuffer
(and byte-compile-current-file
(byte-compile-insert-header byte-compile-current-file
- byte-compile-outbuffer))
+ byte-compile--outbuffer))
(goto-char (point-min))
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have been
;; Fix up the header at the front of the output
;; if the buffer contains multibyte characters.
(and byte-compile-current-file
- (with-current-buffer byte-compile-outbuffer
+ (with-current-buffer byte-compile--outbuffer
(byte-compile-fix-header byte-compile-current-file)))))
- byte-compile-outbuffer))
+ byte-compile--outbuffer))
(defun byte-compile-fix-header (filename)
"If the current buffer has any multibyte characters, insert a version test."
(print-gensym t)
(print-circle ; handle circular data structures
(not byte-compile-disable-print-circle)))
- (princ "\n" byte-compile-outbuffer)
- (prin1 form byte-compile-outbuffer)
+ (princ "\n" byte-compile--outbuffer)
+ (prin1 form byte-compile--outbuffer)
nil)))
(defvar print-gensym-alist) ;Used before print-circle existed.
;; We need to examine byte-compile-dynamic-docstrings
;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
- (with-current-buffer byte-compile-outbuffer
+ (with-current-buffer byte-compile--outbuffer
(let (position)
;; Insert the doc string, and make it a comment with #@LENGTH.
(if preface
(progn
(insert preface)
- (prin1 name byte-compile-outbuffer)))
+ (prin1 name byte-compile--outbuffer)))
(insert (car info))
(let ((print-escape-newlines t)
(print-quoted t)
(print-continuous-numbering t)
print-number-table
(index 0))
- (prin1 (car form) byte-compile-outbuffer)
+ (prin1 (car form) byte-compile--outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
(setq position (- (position-bytes position)
(point-min) -1))
(princ (format "(#$ . %d) nil" position)
- byte-compile-outbuffer)
+ byte-compile--outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
((= index (nth 1 info))
(if position
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
position)
- byte-compile-outbuffer)
+ byte-compile--outbuffer)
(let ((print-escape-newlines nil))
(goto-char (prog1 (1+ (point))
- (prin1 (car form) byte-compile-outbuffer)))
+ (prin1 (car form)
+ byte-compile--outbuffer)))
(insert "\\\n")
(goto-char (point-max)))))
(t
- (prin1 (car form) byte-compile-outbuffer)))))
+ (prin1 (car form) byte-compile--outbuffer)))))
(insert (nth 2 info)))))
nil)
;; Remove declarations from the body of the macro definition.
(when macrop
(dolist (decl (byte-compile-defmacro-declaration form))
- (prin1 decl byte-compile-outbuffer)))
+ (prin1 decl byte-compile--outbuffer)))
(let* ((code (byte-compile-lambda (nthcdr 2 form) t)))
(if this-one
- (setcdr this-one code)
+ ;; A definition in b-c-initial-m-e should always take precedence
+ ;; during compilation, so don't let it be redefined. (Bug#8647)
+ (or (and macrop
+ (assq name byte-compile-initial-macro-environment))
+ (setcdr this-one code))
(set this-kind
(cons (cons name code)
(symbol-value this-kind))))
(and (atom code) byte-compile-dynamic
1)
nil))
- (princ ")" byte-compile-outbuffer)
+ (princ ")" byte-compile--outbuffer)
nil)))
;; Print Lisp object EXP in the output file, inside a comment,
;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
(defun byte-compile-output-as-comment (exp quoted)
(let ((position (point)))
- (with-current-buffer byte-compile-outbuffer
+ (with-current-buffer byte-compile--outbuffer
;; Insert EXP, and make it a comment with #@LENGTH.
(insert " ")
(if quoted
- (prin1 exp byte-compile-outbuffer)
- (princ exp byte-compile-outbuffer))
+ (prin1 exp byte-compile--outbuffer)
+ (princ exp byte-compile--outbuffer))
(goto-char position)
;; Quote certain special characters as needed.
;; get_doc_string in doc.c does the unquoting.
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
- (byte-compile-lexical-environment lexenv)
+ (byte-compile--lexical-environment lexenv)
(byte-compile-reserved-constants (or reserved-csts 0))
(byte-compile-output nil))
(if (memq byte-optimize '(t source))
(when (and lexical-binding (eq output-type 'lambda))
;; See how many arguments there are, and set the current stack depth
;; accordingly.
- (setq byte-compile-depth (length byte-compile-lexical-environment))
+ (setq byte-compile-depth (length byte-compile--lexical-environment))
;; If there are args, output a tag to record the initial
;; stack-depth for the optimizer.
(when (> byte-compile-depth 0)
;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
;; file -> as progn, but takes both quotes and atoms, and longer forms.
(let (rest
- (byte-compile--for-effect for-effect) ;FIXME: Probably unused!
(maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
tmp body)
(cond
That command is designed for interactive use only" fn))
(if (and (fboundp (car form))
(eq (car-safe (symbol-function (car form))) 'macro))
- (byte-compile-report-error
- (format "Forgot to expand macro %s" (car form))))
+ (byte-compile-log-warning
+ (format "Forgot to expand macro %s" (car form)) nil :error))
(if (and handler
;; Make sure that function exists. This is important
;; for CL compiler macros since the symbol may be
(when (and (byte-compile-warning-enabled-p 'callargs)
(symbolp (car form)))
(if (memq (car form)
- '(custom-declare-group
- ;; custom-declare-variable custom-declare-face
- ))
+ '(custom-declare-group custom-declare-variable
+ custom-declare-face))
(byte-compile-nogroup-warn form))
(when (get (car form) 'byte-obsolete-info)
(byte-compile-warn-obsolete (car form)))
(byte-compile-out-tag endtag)))
(defun byte-compile-unfold-bcf (form)
+ "Inline call to byte-code-functions."
(let* ((byte-compile-bound-variables byte-compile-bound-variables)
(fun (car form))
(fargs (aref fun 0))
(cond
((<= (+ alen alen) fmax2)
;; Add missing &optional (or &rest) arguments.
- (dotimes (i (- (/ (1+ fmax2) 2) alen))
+ (dotimes (_ (- (/ (1+ fmax2) 2) alen))
(byte-compile-push-constant nil)))
((zerop (logand fmax2 1))
(byte-compile-log-warning "Too many arguments for inlined function"
(assert (eq byte-compile-depth (1+ start-depth))
nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
-(defun byte-compile-check-variable (var &optional binding)
- "Do various error checks before a use of the variable VAR.
-If BINDING is non-nil, VAR is being bound."
+(defun byte-compile-check-variable (var access-type)
+ "Do various error checks before a use of the variable VAR."
(when (symbolp var)
(byte-compile-set-symbol-position var))
(cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants)
- (byte-compile-warn (if binding
+ (byte-compile-warn (if (eq access-type 'let-bind)
"attempt to let-bind %s `%s`"
"variable reference to %s `%s'")
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))))
- ((and (get var 'byte-obsolete-variable)
- (not (memq var byte-compile-not-obsolete-vars)))
+ ((let ((od (get var 'byte-obsolete-variable)))
+ (and od
+ (not (memq var byte-compile-not-obsolete-vars))
+ (or (case (nth 1 od)
+ (set (not (eq access-type 'reference)))
+ (get (eq access-type 'reference))
+ (t t)))))
(byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op var)
(defun byte-compile-dynamic-variable-bind (var)
"Generate code to bind the lexical variable VAR to the top-of-stack value."
- (byte-compile-check-variable var t)
+ (byte-compile-check-variable var 'let-bind)
(push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var))
(defun byte-compile-variable-ref (var)
"Generate code to push the value of the variable VAR on the stack."
- (byte-compile-check-variable var)
- (let ((lex-binding (assq var byte-compile-lexical-environment)))
+ (byte-compile-check-variable var 'reference)
+ (let ((lex-binding (assq var byte-compile--lexical-environment)))
(if lex-binding
;; VAR is lexically bound
(byte-compile-stack-ref (cdr lex-binding))
(defun byte-compile-variable-set (var)
"Generate code to set the variable VAR from the top-of-stack value."
- (byte-compile-check-variable var)
- (let ((lex-binding (assq var byte-compile-lexical-environment)))
+ (byte-compile-check-variable var 'assign)
+ (let ((lex-binding (assq var byte-compile--lexical-environment)))
(if lex-binding
;; VAR is lexically bound
(byte-compile-stack-set (cdr lex-binding))
(byte-defop-compiler bobp 0)
(byte-defop-compiler current-buffer 0)
;;(byte-defop-compiler read-char 0) ;; obsolete
+;; (byte-defop-compiler interactive-p 0) ;; Obsolete.
(byte-defop-compiler widen 0)
(byte-defop-compiler end-of-line 0-1)
(byte-defop-compiler forward-char 0-1)
(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure)
(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
-(defconst byte-compile--env-var (make-symbol "env"))
-
(defun byte-compile-make-closure (form)
+ "Byte-compile the special `internal-make-closure' form."
(if byte-compile--for-effect (setq byte-compile--for-effect nil)
(let* ((vars (nth 1 form))
(env (nth 2 form))
',(aref fun 0) ',(aref fun 1)
(vconcat (vector . ,env) ',(aref fun 2))
,@(nthcdr 3 (mapcar (lambda (x) `',x) fun)))))))
-
(defun byte-compile-get-closed-var (form)
+ "Byte-compile the special `internal-get-closed-var' form."
(if byte-compile--for-effect (setq byte-compile--for-effect nil)
- (byte-compile-out 'byte-constant ;; byte-closed-var
- (nth 1 form))))
+ (byte-compile-out 'byte-constant (nth 1 form))))
;; Compile a function that accepts one or more args and is right-associative.
;; We do it by left-associativity so that the operations
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant (if (symbolp (nth 1 form))
- (nth 1 form)
- (byte-compile-lambda (nth 1 form)))))
+ (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form)))
+ (byte-compile-lambda (nth 1 form))
+ (nth 1 form))))
(defun byte-compile-indent-to (form)
(let ((len (length form)))
(keywordp var)))
(defun byte-compile-bind (var init-lexenv)
- "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'.
+ "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
INIT-LEXENV should be a lexical-environment alist describing the
positions of the init value that have been pushed on the stack.
Return non-nil if the TOS value was popped."
(cond ((not (byte-compile-not-lexical-var-p var))
;; VAR is a simple stack-allocated lexical variable
(push (assq var init-lexenv)
- byte-compile-lexical-environment)
+ byte-compile--lexical-environment)
nil)
((eq var (caar init-lexenv))
;; VAR is dynamic and is on the top of the
(let ((num-dynamic-bindings 0))
(dolist (clause clauses)
(unless (assq (if (consp clause) (car clause) clause)
- byte-compile-lexical-environment)
+ byte-compile--lexical-environment)
(setq num-dynamic-bindings (1+ num-dynamic-bindings))))
(unless (zerop num-dynamic-bindings)
(byte-compile-out 'byte-unbind num-dynamic-bindings)))
(push (byte-compile-push-binding-init var) init-lexenv)))
;; New scope.
(let ((byte-compile-bound-variables byte-compile-bound-variables)
- (byte-compile-lexical-environment byte-compile-lexical-environment))
+ (byte-compile--lexical-environment
+ byte-compile--lexical-environment))
;; Bind the variables.
;; For `let', do it in reverse order, because it makes no
;; semantic difference, but it is a lot more efficient since the
"Compiler error: `%s' has no `byte-compile-negated-op' property"
(car form)))
(cdr form))))
-
\f
;;; other tricky macro-like special-forms
(byte-defop-compiler-1 save-excursion)
(byte-defop-compiler-1 save-current-buffer)
(byte-defop-compiler-1 save-restriction)
+;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro.
+;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
(byte-defop-compiler-1 track-mouse)
(defun byte-compile-catch (form)
(if (eq fun 'defconst)
;; `defconst' sets `var' unconditionally.
(let ((tmp (make-symbol "defconst-tmp-var")))
+ ;; Quote with `quote' to prevent byte-compiling the body,
+ ;; which would lead to an inf-loop.
`(funcall '(lambda (,tmp) (defconst ,var ,tmp))
,value))
;; `defvar' sets `var' only when unbound.
;; Compile normally, but deal with warnings for the function being defined.
(put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias)
+;; Used for eieio--defalias as well.
(defun byte-compile-file-form-defalias (form)
(if (and (consp (cdr form)) (consp (nth 1 form))
(eq (car (nth 1 form)) 'quote)
(defun byte-compile-form-make-variable-buffer-local (form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
+(byte-defop-compiler-1 add-to-list byte-compile-add-to-list)
+(defun byte-compile-add-to-list (form)
+ ;; FIXME: This could be used for `set' as well, except that it's got
+ ;; its own opcode, so the final `byte-compile-normal-call' needs to
+ ;; be replaced with something else.
+ (pcase form
+ (`(,fun ',var . ,_)
+ (byte-compile-check-variable var 'assign)
+ (if (assq var byte-compile--lexical-environment)
+ (byte-compile-log-warning
+ (format "%s cannot use lexical var `%s'" fun var)
+ nil :error)
+ (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+ (boundp var)
+ (memq var byte-compile-bound-variables)
+ (memq var byte-compile-free-references))
+ (byte-compile-warn "assignment to free variable `%S'" var)
+ (push var byte-compile-free-references)))))
+ (byte-compile-normal-call form))
\f
;;; tags
;; that take OPERAND values off the stack and push a result, for
;; a total of 1 - OPERAND
(- 1 operand))))
-
+
(defun byte-compile-out (op &optional operand)
(push (cons op operand) byte-compile-output)
(if (eq op 'byte-return)
(setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
))
-
-(defun byte-compile-delay-out (&optional stack-used stack-adjust)
- "Add a placeholder to the output, which can be used to later add byte-codes.
-Return a position tag that can be passed to `byte-compile-delayed-out'
-to add the delayed byte-codes. STACK-USED is the maximum amount of
-stack-spaced used by the delayed byte-codes (defaulting to 0), and
-STACK-ADJUST is the amount by which the later-added code will adjust the
-stack (defaulting to 0); the byte-codes added later _must_ adjust the
-stack by this amount! If STACK-ADJUST is 0, then it's not necessary to
-actually add anything later; the effect as if nothing was added at all."
- ;; We just add a no-op to `byte-compile-output', and return a pointer to
- ;; the tail of the list; `byte-compile-delayed-out' uses list surgery
- ;; to add the byte-codes.
- (when stack-used
- (setq byte-compile-maxdepth
- (max byte-compile-depth (+ byte-compile-depth (or stack-used 0)))))
- (when stack-adjust
- (setq byte-compile-depth
- (+ byte-compile-depth stack-adjust)))
- (push (cons nil (or stack-adjust 0)) byte-compile-output))
-
-(defun byte-compile-delayed-out (position op &optional operand)
- "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND.
-POSITION should a position returned by `byte-compile-delay-out'.
-Return a new position, which can be used to add further operations."
- (unless (null (caar position))
- (error "Bad POSITION arg to `byte-compile-delayed-out'"))
- ;; This is kind of like `byte-compile-out', but we splice into the list
- ;; where POSITION is. We don't bother updating `byte-compile-maxdepth'
- ;; because that was already done by `byte-compile-delay-out', but we do
- ;; update the relative operand stored in the no-op marker currently at
- ;; POSITION; since we insert before that marker, this means that if the
- ;; caller doesn't insert a sequence of byte-codes that matches the expected
- ;; operand passed to `byte-compile-delay-out', then the nop will still have
- ;; a non-zero operand when `byte-compile-lapcode' is called, which will
- ;; cause an error to be signaled.
-
- ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op
- (setcdr (car position)
- (- (cdar position) (byte-compile-stack-adjustment op operand)))
- ;; Add the new operation onto the list tail at POSITION
- (setcdr position (cons (cons op operand) (cdr position)))
- position)
-
\f
;;; call tree stuff