;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
-;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software
+;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2014 Free Software
;; Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
(t
(append byte-compile-warnings (list warning)))))))
-(defvar byte-compile-interactive-only-functions
- '(beginning-of-buffer end-of-buffer replace-string replace-regexp
- insert-file insert-buffer insert-file-literally previous-line next-line
- goto-line comint-run delete-backward-char)
+(defvar byte-compile-interactive-only-functions nil
"List of commands that are not meant to be called from Lisp.")
+(make-obsolete-variable 'byte-compile-interactive-only-functions
+ "use the `interactive-only' symbol property instead"
+ "24.4")
(defvar byte-compile-not-obsolete-vars nil
"List of variables that shouldn't be reported as obsolete.")
(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))
- (push 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.
(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
(byte-compile-variable-ref form))))
((symbolp (car form))
(let* ((fn (car form))
- (handler (get fn 'byte-compile)))
+ (handler (get fn 'byte-compile))
+ (interactive-only
+ (or (get fn 'interactive-only)
+ (memq fn byte-compile-interactive-only-functions))))
(when (macroexp--const-symbol-p fn)
(byte-compile-warn "`%s' called as a function" fn))
- (and (byte-compile-warning-enabled-p 'interactive-only)
- (memq fn byte-compile-interactive-only-functions)
- (byte-compile-warn "`%s' used from Lisp code\n\
-That command is designed for interactive use only" fn))
+ (when (and (byte-compile-warning-enabled-p 'interactive-only)
+ interactive-only)
+ (byte-compile-warn "`%s' is for interactive use only%s"
+ fn
+ (cond ((stringp interactive-only)
+ (format "; %s" interactive-only))
+ ((and (symbolp 'interactive-only)
+ (not (eq interactive-only t)))
+ (format "; use `%s' instead."
+ interactive-only))
+ (t "."))))
(if (and (fboundp (car form))
(eq (car-safe (symbol-function (car form))) 'macro))
(byte-compile-log-warning
'(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)
(let ((f (nth 1 form)))
(when (and (symbolp f)
(byte-compile-warning-enabled-p 'callargs))
- (when (get f 'byte-obsolete-info)
- (byte-compile-warn-obsolete (car form)))
-
- ;; Check to see if the function will be available at runtime
- ;; and/or remember its arity if it's unknown.
- (or (and (or (fboundp f) ; Might be a subr or autoload.
- (byte-compile-fdefinition (car form) nil))
- (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 t (cdr cons))
- (push t (cdr cons)))
- (push (list f t)
- byte-compile-unresolved-functions)))))
+ (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)
HCoop / bpt / emacs.git / blobdiff