;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
-;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013
+;; Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
(byte-defop 40 0 byte-unbind "for unbinding special bindings")
;; codes 8-47 are consumed by the preceding opcodes
-;; unused: 48-55
+;; New (in Emacs-24.4) bytecodes for more efficient handling of non-local exits
+;; (especially useful in lexical-binding code).
+(byte-defop 48 0 byte-pophandler)
+(byte-defop 50 -1 byte-pushcatch)
+(byte-defop 49 -1 byte-pushconditioncase)
+
+;; unused: 51-55
(byte-defop 56 -1 byte-nth)
(byte-defop 57 0 byte-symbolp)
(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
byte-goto-if-nil-else-pop
- byte-goto-if-not-nil-else-pop)
+ byte-goto-if-not-nil-else-pop
+ byte-pushcatch byte-pushconditioncase)
"List of byte-codes whose offset is a pc.")
(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
(format "%d" (car signature)))
(t (format "%d-%d" (car signature) (cdr signature)))))
+(defun byte-compile-function-warn (f nargs def)
+ (when (get f 'byte-obsolete-info)
+ (byte-compile-warn-obsolete f))
+
+ ;; Check to see if the function will be available at runtime
+ ;; and/or remember its arity if it's unknown.
+ (or (and (or def (fboundp f)) ; might be a subr or autoload.
+ (not (memq f byte-compile-noruntime-functions)))
+ (eq f byte-compile-current-form) ; ## This doesn't work
+ ; with recursion.
+ ;; It's a currently-undefined function.
+ ;; Remember number of args in call.
+ (let ((cons (assq f byte-compile-unresolved-functions)))
+ (if cons
+ (or (memq nargs (cdr cons))
+ (push nargs (cdr cons)))
+ (push (list f nargs)
+ byte-compile-unresolved-functions)))))
;; Warn if the form is calling a function with the wrong number of arguments.
(defun byte-compile-callargs-warn (form)
"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 def (fboundp (car form))) ; might be a subr or autoload.
- (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.
- ;; Remember number of args in call.
- (let ((cons (assq (car form) byte-compile-unresolved-functions))
- (n (length (cdr form))))
- (if cons
- (or (memq n (cdr cons))
- (setcdr cons (cons n (cdr cons))))
- (push (list (car form) n)
- byte-compile-unresolved-functions))))))
+ (byte-compile-function-warn (car form) (length (cdr form)) def)))
(defun byte-compile-format-warn (form)
"Warn if FORM is `format'-like with inconsistent args.
;; This is the first definition. See if previous calls are compatible.
(let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max)
- (when calls
+ (setq byte-compile-unresolved-functions
+ (delq calls byte-compile-unresolved-functions))
+ (setq calls (delq t calls)) ;Ignore higher-order uses of the function.
+ (when (cdr calls)
(when (and (symbolp name)
(eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand))
name
(byte-compile-arglist-signature-string sig)
(if (equal sig '(1 . 1)) " arg" " args")
- (byte-compile-arglist-signature-string (cons min max))))
-
- (setq byte-compile-unresolved-functions
- (delq calls byte-compile-unresolved-functions)))))))
+ (byte-compile-arglist-signature-string (cons min max)))))))))
(defvar byte-compile-cl-functions nil
"List of functions defined in CL.")
(message "Checking %s..." directory)
(dolist (file (directory-files directory))
(let ((source (expand-file-name file directory)))
- (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.
- (when (or (null arg) (eq 0 arg)
- (y-or-n-p (concat "Check " source "? ")))
- (setq directories (nconc directories (list source))))
+ (if (file-directory-p source)
+ (and (not (member file '("RCS" "CVS")))
+ (not (eq ?\. (aref file 0)))
+ (not (file-symlink-p source))
+ ;; This file is a subdirectory. Handle them differently.
+ (or (null arg) (eq 0 arg)
+ (y-or-n-p (concat "Check " source "? ")))
+ (setq directories (nconc directories (list source))))
;; It is an ordinary file. Decide whether to compile it.
(if (and (string-match emacs-lisp-file-regexp source)
;; The next 2 tests avoid compiling lock files
(defun byte-compile-file-form-autoload (form)
(and (let ((form form))
(while (if (setq form (cdr form)) (macroexp-const-p (car form))))
- (null form)) ;Constants only
+ (null form)) ;Constants only
(memq (eval (nth 5 form)) '(t macro)) ;Macro
- (eval form)) ;Define the autoload.
+ (eval form)) ;Define the autoload.
;; Avoid undefined function warnings for the autoload.
- (when (and (consp (nth 1 form))
- (eq (car (nth 1 form)) 'quote)
- (consp (cdr (nth 1 form)))
- (symbolp (nth 1 (nth 1 form))))
- ;; Don't add it if it's already defined. Otherwise, it might
- ;; hide the actual definition. However, do remove any entry from
- ;; byte-compile-noruntime-functions, in case we have an autoload
- ;; of foo-func following an (eval-when-compile (require 'foo)).
- (unless (fboundp (nth 1 (nth 1 form)))
- (push (cons (nth 1 (nth 1 form))
- (cons 'autoload (cdr (cdr form))))
- byte-compile-function-environment))
- ;; If an autoload occurs _before_ the first call to a function,
- ;; byte-compile-callargs-warn does not add an entry to
- ;; byte-compile-unresolved-functions. Here we mimic the logic
- ;; of byte-compile-callargs-warn so as not to warn if the
- ;; autoload comes _after_ the function call.
- ;; Alternatively, similar logic could go in
- ;; byte-compile-warn-about-unresolved-functions.
- (if (memq (nth 1 (nth 1 form)) byte-compile-noruntime-functions)
- (setq byte-compile-noruntime-functions
- (delq (nth 1 (nth 1 form)) byte-compile-noruntime-functions)
- byte-compile-noruntime-functions)
- (setq byte-compile-unresolved-functions
- (delq (assq (nth 1 (nth 1 form))
- byte-compile-unresolved-functions)
- byte-compile-unresolved-functions))))
+ (pcase (nth 1 form)
+ (`',(and (pred symbolp) funsym)
+ ;; Don't add it if it's already defined. Otherwise, it might
+ ;; hide the actual definition. However, do remove any entry from
+ ;; byte-compile-noruntime-functions, in case we have an autoload
+ ;; of foo-func following an (eval-when-compile (require 'foo)).
+ (unless (fboundp funsym)
+ (push (cons funsym (cons 'autoload (cdr (cdr form))))
+ byte-compile-function-environment))
+ ;; If an autoload occurs _before_ the first call to a function,
+ ;; byte-compile-callargs-warn does not add an entry to
+ ;; byte-compile-unresolved-functions. Here we mimic the logic
+ ;; of byte-compile-callargs-warn so as not to warn if the
+ ;; autoload comes _after_ the function call.
+ ;; Alternatively, similar logic could go in
+ ;; byte-compile-warn-about-unresolved-functions.
+ (if (memq funsym byte-compile-noruntime-functions)
+ (setq byte-compile-noruntime-functions
+ (delq funsym byte-compile-noruntime-functions)
+ byte-compile-noruntime-functions)
+ (setq byte-compile-unresolved-functions
+ (delq (assq funsym byte-compile-unresolved-functions)
+ byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
form
;; No doc string, so we can compile this as a normal form.
'(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-callargs-warn form))
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
'((0 . byte-compile-no-args)
(1 . byte-compile-one-arg)
(2 . byte-compile-two-args)
+ (2-and . byte-compile-and-folded)
(3 . byte-compile-three-args)
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler set 2)
-(byte-defop-compiler (= byte-eqlsign) 2)
-(byte-defop-compiler (< byte-lss) 2)
-(byte-defop-compiler (> byte-gtr) 2)
-(byte-defop-compiler (<= byte-leq) 2)
-(byte-defop-compiler (>= byte-geq) 2)
+(byte-defop-compiler (= byte-eqlsign) 2-and)
+(byte-defop-compiler (< byte-lss) 2-and)
+(byte-defop-compiler (> byte-gtr) 2-and)
+(byte-defop-compiler (<= byte-leq) 2-and)
+(byte-defop-compiler (>= byte-geq) 2-and)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3)
(byte-compile-form (nth 2 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
+(defun byte-compile-and-folded (form)
+ "Compile calls to functions like `<='.
+These implicitly `and' together a bunch of two-arg bytecodes."
+ (let ((l (length form)))
+ (cond
+ ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
+ ((= l 3) (byte-compile-two-args form))
+ (t (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
+ (,(car form) ,@(nthcdr 2 form))))))))
+
(defun byte-compile-three-args (form)
(if (not (= (length form) 4))
(byte-compile-subr-wrong-args form 3)
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form)))
- (byte-compile-lambda (nth 1 form))
- (nth 1 form))))
-
+ (let ((f (nth 1 form)))
+ (when (and (symbolp f)
+ (byte-compile-warning-enabled-p 'callargs))
+ (byte-compile-function-warn f t (byte-compile-fdefinition f nil)))
+
+ (byte-compile-constant (if (eq 'lambda (car-safe f))
+ (byte-compile-lambda f)
+ f))))
+
(defun byte-compile-indent-to (form)
(let ((len (length form)))
(cond ((= len 2)
;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
(byte-defop-compiler-1 track-mouse)
+(defvar byte-compile--use-old-handlers t
+ "If nil, use new byte codes introduced in Emacs-24.4.")
+
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
- (pcase (cddr form)
- (`(:fun-body ,f)
- (byte-compile-form `(list 'funcall ,f)))
- (body
- (byte-compile-push-constant
- (byte-compile-top-level (cons 'progn body) byte-compile--for-effect))))
- (byte-compile-out 'byte-catch 0))
+ (if (not byte-compile--use-old-handlers)
+ (let ((endtag (byte-compile-make-tag)))
+ (byte-compile-goto 'byte-pushcatch endtag)
+ (byte-compile-body (cddr form) nil)
+ (byte-compile-out 'byte-pophandler)
+ (byte-compile-out-tag endtag))
+ (pcase (cddr form)
+ (`(:fun-body ,f)
+ (byte-compile-form `(list 'funcall ,f)))
+ (body
+ (byte-compile-push-constant
+ (byte-compile-top-level (cons 'progn body) byte-compile--for-effect))))
+ (byte-compile-out 'byte-catch 0)))
(defun byte-compile-unwind-protect (form)
(pcase (cddr form)
(`(:fun-body ,f)
- (byte-compile-form `(list (list 'funcall ,f))))
+ (byte-compile-form
+ (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f)))
(handlers
- (byte-compile-push-constant
- (byte-compile-top-level-body handlers t))))
+ (if byte-compile--use-old-handlers
+ (byte-compile-push-constant
+ (byte-compile-top-level-body handlers t))
+ (byte-compile-form `#'(lambda () ,@handlers)))))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1))
(_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form))))))))
(defun byte-compile-condition-case (form)
+ (if byte-compile--use-old-handlers
+ (byte-compile-condition-case--old form)
+ (byte-compile-condition-case--new form)))
+
+(defun byte-compile-condition-case--old (form)
(let* ((var (nth 1 form))
(fun-bodies (eq var :fun-body))
(byte-compile-bound-variables
(byte-compile-push-constant compiled-clauses)))
(byte-compile-out 'byte-condition-case 0)))
+(defun byte-compile-condition-case--new (form)
+ (let* ((var (nth 1 form))
+ (body (nth 2 form))
+ (depth byte-compile-depth)
+ (clauses (mapcar (lambda (clause)
+ (cons (byte-compile-make-tag) clause))
+ (nthcdr 3 form)))
+ (endtag (byte-compile-make-tag)))
+ (byte-compile-set-symbol-position 'condition-case)
+ (unless (symbolp var)
+ (byte-compile-warn
+ "`%s' is not a variable-name or nil (in condition-case)" var))
+
+ (dolist (clause (reverse clauses))
+ (let ((condition (nth 1 clause)))
+ (unless (consp condition) (setq condition (list condition)))
+ (dolist (c condition)
+ (unless (and c (symbolp c))
+ (byte-compile-warn
+ "`%S' is not a condition name (in condition-case)" c))
+ ;; In reality, the `error-conditions' property is only required
+ ;; for the argument to `signal', not to `condition-case'.
+ ;;(unless (consp (get c 'error-conditions))
+ ;; (byte-compile-warn
+ ;; "`%s' is not a known condition name (in condition-case)"
+ ;; c))
+ )
+ (byte-compile-push-constant condition))
+ (byte-compile-goto 'byte-pushconditioncase (car clause)))
+
+ (byte-compile-form body) ;; byte-compile--for-effect
+ (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+ (byte-compile-goto 'byte-goto endtag)
+
+ (while clauses
+ (let ((clause (pop clauses))
+ (byte-compile-bound-variables byte-compile-bound-variables)
+ (byte-compile--lexical-environment
+ byte-compile--lexical-environment))
+ (setq byte-compile-depth (1+ depth))
+ (byte-compile-out-tag (pop clause))
+ (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+ (cond
+ ((null var) (byte-compile-discard))
+ (lexical-binding
+ (push (cons var (1- byte-compile-depth))
+ byte-compile--lexical-environment))
+ (t (byte-compile-dynamic-variable-bind var)))
+ (byte-compile-body (cdr clause)) ;; byte-compile--for-effect
+ (cond
+ ((null var) nil)
+ (lexical-binding (byte-compile-discard 1 'preserve-tos))
+ (t (byte-compile-out 'byte-unbind 1)))
+ (byte-compile-goto 'byte-goto endtag)))
+
+ (byte-compile-out-tag endtag)))
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(byte-compile-warning-enabled-p 'make-local))
(byte-compile-warn
- "`make-variable-buffer-local' should be called at toplevel"))
+ "`make-variable-buffer-local' not called at toplevel"))
(byte-compile-normal-call form))
(put 'make-variable-buffer-local
'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)