diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/advice.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/autoload.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 441 | ||||
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 2098 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 713 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 23 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 39 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 64 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/disass.el | 13 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 21 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-comp.el | 142 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 59 | ||||
| -rw-r--r-- | lisp/emacs-lisp/float-sup.el | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 37 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 43 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 205 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 4 |
19 files changed, 2516 insertions, 1440 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 915a726ae11..39ea97aa98e 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2535,17 +2535,11 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the argument list of DEFINITION. If DEFINITION could be from a subr then its NAME should be supplied to make subr arglist lookup more efficient." - (cond ((ad-compiled-p definition) - (aref (ad-compiled-code definition) 0)) - ((consp definition) - (car (cdr (ad-lambda-expression definition)))) - ((ad-subr-p definition) - (if name - (ad-subr-arglist name) - ;; otherwise get it from its printed representation: - (setq name (format "%s" definition)) - (string-match "^#<subr \\([^>]+\\)>$" name) - (ad-subr-arglist (intern (match-string 1 name))))))) + (require 'help-fns) + (cond + ((or (ad-macro-p definition) (ad-advice-p definition)) + (help-function-arglist (cdr definition))) + (t (help-function-arglist definition)))) ;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish ;; a defined empty arglist `(nil)' from an undefined arglist: diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d6e7ee9e3cb..5a5d6b88a2d 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -137,7 +137,7 @@ or macro definition or a defcustom)." ;; Special case to autoload some of the macro's declarations. (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) (exps '())) - (when (eq (car decls) 'declare) + (when (eq (car-safe decls) 'declare) ;; FIXME: We'd like to reuse macro-declaration-function, ;; but we can't since it doesn't return anything. (dolist (decl decls) @@ -471,7 +471,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (marker-buffer output-start))) (autoload-print-form autoload))) (error - (message "Error in %s: %S" file err))) + (message "Autoload cookie error in %s:%s %S" + file (count-lines (point-min) (point)) err))) ;; Copy the rest of the line to the output. (princ (buffer-substring diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0f4018dc8da..548fcd133df 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,4 +1,4 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler +;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*- ;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. @@ -186,8 +186,10 @@ (eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) + ;; Newer byte codes for stack-ref make the slot 0 non-nil again. + ;; But the "old disassembler" is *really* ancient by now. + ;; (if (aref byte-code-vector 0) + ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply 'format format (let (c a) @@ -242,58 +244,72 @@ sexp))) (cdr form)))) - -;; Splice the given lap code into the current instruction stream. -;; If it has any labels in it, you're responsible for making sure there -;; are no collisions, and that byte-compile-tag-number is reasonable -;; after this is spliced in. The provided list is destroyed. -(defun byte-inline-lapcode (lap) - (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) - (defun byte-compile-inline-expand (form) (let* ((name (car form)) - (fn (or (cdr (assq name byte-compile-function-environment)) - (and (fboundp name) (symbol-function name))))) - (if (null fn) - (progn - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) - form) - ;; else - (when (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn)) - (setq fn (or (and (fboundp name) (symbol-function name)) - (cdr (assq name byte-compile-function-environment))))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "File `%s' didn't define `%s'" (nth 1 fn) name)) - (if (and (symbolp fn) (not (eq fn t))) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (byte-code-function-p fn) - (let (string) - (fetch-bytecode fn) - (setq string (aref fn 1)) - ;; Isn't it an error for `string' not to be unibyte?? --stef - (if (fboundp 'string-as-unibyte) - (setq string (string-as-unibyte string))) - ;; `byte-compile-splice-in-already-compiled-code' - ;; takes care of inlining the body. - (cons `(lambda ,(aref fn 0) - (byte-code ,string ,(aref fn 2) ,(aref fn 3))) - (cdr form))) - (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) - ;; Give up on inlining. - form)))))) + (localfn (cdr (assq name byte-compile-function-environment))) + (fn (or localfn (and (fboundp name) (symbol-function name))))) + (when (and (consp fn) (eq (car fn) 'autoload)) + (load (nth 1 fn)) + (setq fn (or (and (fboundp name) (symbol-function name)) + (cdr (assq name byte-compile-function-environment))))) + (pcase fn + (`nil + (byte-compile-warn "attempt to inline `%s' before it was defined" + name) + form) + (`(autoload . ,_) + (error "File `%s' didn't define `%s'" (nth 1 fn) name)) + ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias. + (byte-compile-inline-expand (cons fn (cdr form)))) + ((pred byte-code-function-p) + ;; (message "Inlining byte-code for %S!" name) + ;; The byte-code will be really inlined in byte-compile-unfold-bcf. + `(,fn ,@(cdr form))) + ((or (and `(lambda ,args . ,body) (let env nil)) + `(closure ,env ,args . ,body)) + (if (not (or (eq fn localfn) ;From the same file => same mode. + (eq (not lexical-binding) (not env)))) ;Same mode. + ;; While byte-compile-unfold-bcf can inline dynbind byte-code into + ;; letbind byte-code (or any other combination for that matter), we + ;; can only inline dynbind source into dynbind source or letbind + ;; source into letbind source. + ;; FIXME: we could of course byte-compile the inlined function + ;; first, and then inline its byte-code. + form + (let ((renv ())) + ;; Turn the function's closed vars (if any) into local let bindings. + (dolist (binding env) + (cond + ((consp binding) + ;; We check shadowing by the args, so that the `let' can be + ;; moved within the lambda, which can then be unfolded. + ;; FIXME: Some of those bindings might be unused in `body'. + (unless (memq (car binding) args) ;Shadowed. + (push `(,(car binding) ',(cdr binding)) renv))) + ((eq binding t)) + (t (push `(defvar ,binding) body)))) + (let ((newfn (byte-compile-preprocess + (if (null renv) + `(lambda ,args ,@body) + `(lambda ,args (let ,(nreverse renv) ,@body)))))) + (if (eq (car-safe newfn) 'function) + (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) + (byte-compile-log-warning + (format "Inlining closure %S failed" name)) + form))))) + + (t ;; Give up on inlining. + form)))) ;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) + ;; In lexical-binding mode, let and functions don't bind vars in the same way + ;; (let obey special-variable-p, but functions don't). But luckily, this + ;; doesn't matter here, because function's behavior is underspecified so it + ;; can safely be turned into a `let', even though the reverse is not true. (or name (setq name "anonymous lambda")) (let ((lambda (car form)) (values (cdr form))) - (if (byte-code-function-p lambda) - (setq lambda (list 'lambda (aref lambda 0) - (list 'byte-code (aref lambda 1) - (aref lambda 2) (aref lambda 3))))) (let ((arglist (nth 1 lambda)) (body (cdr (cdr lambda))) optionalp restp @@ -302,6 +318,7 @@ (setq body (cdr body))) (if (and (consp (car body)) (eq 'interactive (car (car body)))) (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. (while arglist (cond ((eq (car arglist) '&optional) ;; ok, I'll let this slide because funcall_lambda() does... @@ -379,8 +396,7 @@ (and (nth 1 form) (not for-effect) form)) - ((or (byte-code-function-p fn) - (eq 'lambda (car-safe fn))) + ((eq 'lambda (car-safe fn)) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion @@ -455,8 +471,8 @@ (byte-optimize-form (nth 2 form) for-effect) (byte-optimize-body (nthcdr 3 form) for-effect))))) - ((memq fn '(and or)) ; remember, and/or are control structures. - ;; take forms off the back until we can't any more. + ((memq fn '(and or)) ; Remember, and/or are control structures. + ;; Take forms off the back until we can't any more. ;; In the future it could conceivably be a problem that the ;; subexpressions of these forms are optimized in the reverse ;; order, but it's ok for now. @@ -471,7 +487,8 @@ (byte-compile-log " all subforms of %s called for effect; deleted" form)) (and backwards - (cons fn (nreverse (mapcar 'byte-optimize-form backwards))))) + (cons fn (nreverse (mapcar 'byte-optimize-form + backwards))))) (cons fn (mapcar 'byte-optimize-form (cdr form))))) ((eq fn 'interactive) @@ -479,8 +496,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) + ((memq fn '(defun defmacro function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -511,23 +527,11 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) - ;; If optimization is on, this is the only place that macros are - ;; expanded. If optimization is off, then macroexpansion happens - ;; in byte-compile-form. Otherwise, the macros are already expanded - ;; by the time that is reached. - ((not (eq form - (setq form (macroexpand form - byte-compile-macro-environment)))) - (byte-optimize-form form for-effect)) - - ;; Support compiler macros as in cl.el. - ((and (fboundp 'compiler-macroexpand) - (symbolp (car-safe form)) - (get (car-safe form) 'cl-compiler-macro) - (not (eq form - (with-no-warnings - (setq form (compiler-macroexpand form)))))) - (byte-optimize-form form for-effect)) + ;; Neeeded as long as we run byte-optimize-form after cconv. + ((eq fn 'internal-make-closure) form) + + ((byte-code-function-p fn) + (cons fn (mapcar #'byte-optimize-form (cdr form)))) ((not (symbolp fn)) (byte-compile-warn "`%s' is a malformed function" @@ -605,7 +609,7 @@ (defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all forms is a list of + ;; Optimize the cdr of a progn or implicit progn; all forms is a list of ;; forms, all but the last of which are optimized with the assumption that ;; they are being called for effect. the last is for-effect as well if ;; all-for-effect is true. returns a new list of forms. @@ -1085,7 +1089,7 @@ (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function)) (cons (nth 1 fn) (cdr (cdr form))) - form))) + form))) (defun byte-optimize-apply (form) ;; If the last arg is a literal constant, turn this into a funcall. @@ -1291,63 +1295,51 @@ (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) nil) - -(defun byte-compile-splice-in-already-compiled-code (form) - ;; form is (byte-code "..." [...] n) - (if (not (memq byte-optimize '(t lap))) - (byte-compile-normal-call form) - (byte-inline-lapcode - (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) - (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) - byte-compile-maxdepth)) - (setq byte-compile-depth (1+ byte-compile-depth)))) - -(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) - (defconst byte-constref-ops '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) +;; Used and set dynamically in byte-decompile-bytecode-1. +(defvar bytedecomp-op) +(defvar bytedecomp-ptr) + ;; This function extracts the bitfields from variable-length opcodes. ;; Originally defined in disass.el (which no longer uses it.) - -(defun disassemble-offset () +(defun disassemble-offset (bytes) "Don't call this!" - ;; fetch and return the offset for the current opcode. - ;; return nil if this opcode has no offset - ;; Used and set dynamically in byte-decompile-bytecode-1. - (defvar bytedecomp-op) - (defvar bytedecomp-ptr) - (defvar bytedecomp-bytes) + ;; Fetch and return the offset for the current opcode. + ;; Return nil if this opcode has no offset. (cond ((< bytedecomp-op byte-nth) (let ((tem (logand bytedecomp-op 7))) (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) ;; Offset in next byte. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (aref bytedecomp-bytes bytedecomp-ptr)) + (aref bytes bytedecomp-ptr)) ((eq tem 7) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (+ (aref bytedecomp-bytes bytedecomp-ptr) + (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) - (t tem)))) ;offset was in opcode + (lsh (aref bytes bytedecomp-ptr) 8)))) + (t tem)))) ;Offset was in opcode. ((>= bytedecomp-op byte-constant) - (prog1 (- bytedecomp-op byte-constant) ;offset in opcode + (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode. (setq bytedecomp-op byte-constant))) - ((and (>= bytedecomp-op byte-constant2) - (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + ((or (and (>= bytedecomp-op byte-constant2) + (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + (= bytedecomp-op byte-stack-set2)) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (+ (aref bytedecomp-bytes bytedecomp-ptr) + (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) + (lsh (aref bytes bytedecomp-ptr) 8)))) ((and (>= bytedecomp-op byte-listN) - (<= bytedecomp-op byte-insertN)) - (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte - (aref bytedecomp-bytes bytedecomp-ptr)))) + (<= bytedecomp-op byte-discardN)) + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte. + (aref bytes bytedecomp-ptr)))) +(defvar byte-compile-tag-number) ;; This de-compiler is used for inline expansion of compiled functions, ;; and by the disassembler. @@ -1369,27 +1361,26 @@ ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. ;; In that case, we put a pc value into the list ;; before each insn (or its label). -(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec - &optional make-spliceable) - (let ((length (length bytedecomp-bytes)) - (bytedecomp-ptr 0) optr tags bytedecomp-op offset +(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) + (let ((length (length bytes)) + (bytedecomp-ptr 0) optr tags bytedecomp-op offset lap tmp endtag) (while (not (= bytedecomp-ptr length)) (or make-spliceable - (setq lap (cons bytedecomp-ptr lap))) - (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) + (push bytedecomp-ptr lap)) + (setq bytedecomp-op (aref bytes bytedecomp-ptr) optr bytedecomp-ptr - offset (disassemble-offset)) ; this does dynamic-scope magic + ;; This uses dynamic-scope magic. + offset (disassemble-offset bytes)) (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) (cond ((memq bytedecomp-op byte-goto-ops) - ;; it's a pc + ;; It's a pc. (setq offset (cdr (or (assq offset tags) - (car (setq tags - (cons (cons offset - (byte-compile-make-tag)) - tags))))))) + (let ((new (cons offset (byte-compile-make-tag)))) + (push new tags) + new))))) ((cond ((eq bytedecomp-op 'byte-constant2) (setq bytedecomp-op 'byte-constant) t) ((memq bytedecomp-op byte-constref-ops))) @@ -1399,36 +1390,36 @@ offset (if (eq bytedecomp-op 'byte-constant) (byte-compile-get-constant tmp) (or (assq tmp byte-compile-variables) - (car (setq byte-compile-variables - (cons (list tmp) - byte-compile-variables))))))) - ((and make-spliceable - (eq bytedecomp-op 'byte-return)) - (if (= bytedecomp-ptr (1- length)) - (setq bytedecomp-op nil) - (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - bytedecomp-op 'byte-goto)))) + (let ((new (list tmp))) + (push new byte-compile-variables) + new))))) + ((eq bytedecomp-op 'byte-stack-set2) + (setq bytedecomp-op 'byte-stack-set)) + ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq bytedecomp-op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) - lap)) + (push (cons optr (cons bytedecomp-op (or offset 0))) + lap) (setq bytedecomp-ptr (1+ bytedecomp-ptr))) - ;; take off the dummy nil op that we replaced a trailing "return" with. (let ((rest lap)) (while rest (cond ((numberp (car rest))) ((setq tmp (assq (car (car rest)) tags)) - ;; this addr is jumped to + ;; This addr is jumped to. (setcdr rest (cons (cons nil (cdr tmp)) (cdr rest))) (setq tags (delq tmp tags)) (setq rest (cdr rest)))) (setq rest (cdr rest)))) (if tags (error "optimizer error: missed tags %s" tags)) - (if (null (car (cdr (car lap)))) - (setq lap (cdr lap))) (if endtag (setq lap (cons (cons nil endtag) lap))) - ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) + ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) (mapcar (function (lambda (elt) (if (numberp elt) elt @@ -1463,7 +1454,7 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p)) + byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1505,7 +1496,7 @@ ;; The variable `byte-boolean-vars' is now primitive and updated ;; automatically by DEFVAR_BOOL. -(defun byte-optimize-lapcode (lap &optional for-effect) +(defun byte-optimize-lapcode (lap &optional _for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (let (lap0 @@ -1580,9 +1571,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost cost of an extra stack slot. Let's not bother. ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil @@ -1611,14 +1607,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; dup varset-X discard --> varset-X ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 ;; (the varbind variant can emerge from other optimizations) ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest)) + (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1))) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1627,8 +1626,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; it is wrong to do the same thing for the -else-pop variants. ;; ((and (eq 'byte-not (car lap0)) - (or (eq 'byte-goto-if-nil (car lap1)) - (eq 'byte-goto-if-not-nil (car lap1)))) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) (byte-compile-log-lap " not %s\t-->\t%s" lap1 (cons @@ -1647,8 +1645,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; it is wrong to do the same thing for the -else-pop variants. ;; - ((and (or (eq 'byte-goto-if-nil (car lap0)) - (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX (eq 'byte-goto (car lap1)) ; gotoY (eq (cdr lap0) lap2)) ; TAG X (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) @@ -1663,40 +1661,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const goto-if-* --> whatever ;; ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops)) - (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1) (setq rest (cdr rest) lap (delq lap0 (delq lap1 lap)))) (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup ;; We don't optimize the const-X variations on this here, ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. ;; - ((and (eq 'byte-varref (car lap0)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn (setq tmp (cdr rest)) + (setq tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1856,18 +1865,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (cons 'byte-discard byte-conditional-ops))) (not (eq lap1 (car tmp)))) (setq tmp2 (car tmp)) - (cond ((memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop))) + (cond ((when (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" lap0 tmp2 lap0 tmp2) (setcar lap1 (car tmp2)) (setcdr lap1 (cdr tmp2)) ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest))) - (t + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) ;; Jump one step further (byte-compile-log-lap " %s goto [%s]\t-->\t<deleted> goto <skip>" @@ -1876,13 +1888,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (setq lap (delq lap0 lap)) + (setq keep-going t)))) ;; ;; X: varref-Y ... varset-Y goto-X --> ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. ;; ((and (eq (car lap1) 'byte-varset) (eq (car lap2) 'byte-goto) @@ -1955,16 +1972,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they ;; were done in the optimizing loop, and optimizations which there is no - ;; need to do more than once. + ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) (setq rest lap) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) (if (memq (car lap0) byte-constref-ops) - (if (or (eq (car lap0) 'byte-constant) - (eq (car lap0) 'byte-constant2)) + (if (memq (car lap0) '(byte-constant byte-constant2)) (unless (memq (cdr lap0) byte-compile-constants) (setq byte-compile-constants (cons (cdr lap0) byte-compile-constants))) @@ -2008,10 +2025,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-unbind (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. + (setq lap (delq lap0 lap)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setq lap (delq lap0 lap)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 524f4f1b465..3fb3d841ed1 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message If provided, WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." (interactive "aMake function obsolete: \nxObsoletion replacement: ") - (let ((handler (get obsolete-name 'byte-compile))) - (if (eq 'byte-compile-obsolete handler) - (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info))) - (put obsolete-name 'byte-compile 'byte-compile-obsolete)) - (put obsolete-name 'byte-obsolete-info - (list (purecopy current-name) handler (purecopy when)))) + (put obsolete-name 'byte-obsolete-info + ;; The second entry used to hold the `byte-compile' handler, but + ;; is not used any more nowadays. + (list (purecopy current-name) nil (purecopy when))) obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5c845e59c85..7c358a3830e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1,4 +1,4 @@ -;;; bytecomp.el --- compilation of Lisp code into byte code +;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*- ;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011 ;; Free Software Foundation, Inc. @@ -118,12 +118,16 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) +(require 'macroexp) +(require 'cconv) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (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. (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -402,7 +406,7 @@ specify different fields to sort on." (defvar byte-compile-variables nil "List of all variables encountered during compilation of this form.") (defvar byte-compile-bound-variables nil - "List of variables bound in the context of the current form. + "List of dynamic 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.") @@ -415,10 +419,13 @@ This list lives partly on the stack.") '( ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) + (declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (byte-compile-preprocess (cons 'progn body))))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -451,6 +458,10 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile--lexical-environment nil + "The current lexical environment.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -496,11 +507,10 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; unused: 0-7 - ;; These opcodes are special in that they pack their argument into the ;; opcode word. ;; +(byte-defop 0 1 byte-stack-ref "for stack reference") (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -570,7 +580,7 @@ Each element is (INDEX . VALUE)") (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) +;; (byte-defop 116 1 byte-interactive-p) ;Let's not use it any more. ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -606,8 +616,8 @@ otherwise pop it") (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 - "to make a binding to record entire window configuration") +;; (byte-defop 139 0 byte-save-window-excursion ; Obsolete: It's a macro now. +;; "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 @@ -619,17 +629,9 @@ otherwise pop it") ;; 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) +;; Obsolete: `with-output-to-temp-buffer' is a macro now. +;; (byte-defop 144 0 byte-temp-output-buffer-setup) +;; (byte-defop 145 -1 byte-temp-output-buffer-show) ;; these ops are new to v19 @@ -666,7 +668,21 @@ otherwise pop it") (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(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 +;; discard (following one byte & 0x7F) stack entries +;; else +;; discard (following one byte & 0x7F) stack entries _underneath_ TOS +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -713,71 +729,114 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(progn (assert (<= 0 ,(car byte-exprs))) + (cons ,@byte-exprs ,bytes-var)) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaulated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (defun byte-compile-lapcode (lap) "Turns lapcode into bytecode. The lapcode is destroyed." ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. (let ((pc 0) ; Program counter op off ; Operation & offset + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) - (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) + (cond + ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc)) + (t + (setq opcode + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a pseudo op, which + ;; is actually the same as byte-discardN + ;; with a modified argument. + byte-discardN + (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (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) + (integerp off))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is weird in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) + bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) + bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ((and (eq opcode byte-stack-ref) (eq off 0)) + ;; (stack-ref 0) is really just another name for `dup'. + (debug) ;FIXME: When would this happen? + (byte-compile-push-bytecodes byte-dup bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + ;; Patch tag PCs into absolute jumps. + (dolist (bytes-tail patchlist) + (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"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -793,7 +852,7 @@ otherwise pop it") 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) + (prog1 (eval form lexical-binding) (when (byte-compile-warning-enabled-p 'noruntime) (let ((hist-new load-history) (hist-nil-new current-load-list)) @@ -845,7 +904,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-eval-before-compile (form) "Evaluate FORM for `eval-and-compile'." (let ((hist-nil-orig current-load-list)) - (prog1 (eval form) + (prog1 (eval form lexical-binding) ;; (eval-and-compile (require 'cl) turns off warnings for cl functions. ;; FIXME Why does it do that - just as a hack? ;; There are other ways to do this nowadays. @@ -936,7 +995,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." read-symbol-positions-list (byte-compile-delete-first entry read-symbol-positions-list))) - (or (and allow-previous (not (= last byte-compile-last-position))) + (or (and allow-previous + (not (= last byte-compile-last-position))) (> last byte-compile-last-position))))))) (defvar byte-compile-last-warned-form nil) @@ -948,7 +1008,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let* ((inhibit-read-only t) (dir default-directory) (file (cond ((stringp byte-compile-current-file) - (format "%s:" (file-relative-name byte-compile-current-file dir))) + (format "%s:" (file-relative-name + byte-compile-current-file dir))) ((bufferp byte-compile-current-file) (format "Buffer %s:" (buffer-name byte-compile-current-file))) @@ -982,7 +1043,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; This no-op function is used as the value of warning-series ;; to tell inner calls to displaying-byte-compile-warnings ;; not to bind warning-series. -(defun byte-compile-warning-series (&rest ignore) +(defun byte-compile-warning-series (&rest _ignore) nil) ;; (compile-mode) will cause this to be loaded. @@ -1011,13 +1072,15 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (insert "\f\nCompiling " (if (stringp byte-compile-current-file) (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) + (concat "buffer " + (buffer-name byte-compile-current-file))) " at " (current-time-string) "\n") (insert "\f\nCompiling no file at " (current-time-string) "\n")) (when dir (setq default-directory dir) (unless was-same - (insert (format "Entering directory `%s'\n" default-directory)))) + (insert (format "Entering directory `%s'\n" + default-directory)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form nil) ;; Do this after setting default-directory. @@ -1064,13 +1127,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-log-warning (error-message-string error-info) nil :error)) - -;;; Used by make-obsolete. -(defun byte-compile-obsolete (form) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn-obsolete (car form)) - (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler - 'byte-compile-normal-call) form)) ;;; sanity-checking arglists @@ -1110,22 +1166,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (t fn))))))) (defun byte-compile-arglist-signature (arglist) - (let ((args 0) - opts - restp) - (while arglist - (cond ((eq (car arglist) '&optional) - (or opts (setq opts 0))) - ((eq (car arglist) '&rest) - (if (cdr arglist) - (setq restp t - arglist nil))) - (t - (if opts - (setq opts (1+ opts)) + (if (integerp arglist) + ;; New style byte-code arglist. + (cons (logand arglist 127) ;Mandatory. + (if (zerop (logand arglist 128)) ;No &rest. + (lsh arglist -8))) ;Nonrest. + ;; Old style byte-code, or interpreted function. + (let ((args 0) + opts + restp) + (while arglist + (cond ((eq (car arglist) '&optional) + (or opts (setq opts 0))) + ((eq (car arglist) '&rest) + (if (cdr arglist) + (setq restp t + arglist nil))) + (t + (if opts + (setq opts (1+ opts)) (setq args (1+ args))))) - (setq arglist (cdr arglist))) - (cons args (if restp nil (if opts (+ args opts) args))))) + (setq arglist (cdr arglist))) + (cons args (if restp nil (if opts (+ args opts) args)))))) (defun byte-compile-arglist-signatures-congruent-p (old new) @@ -1244,7 +1306,7 @@ extra args." (custom-declare-variable . defcustom)))) (cadr name))) ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when byte-compiling a whole file. + (if (and byte-compile-current-file ;Only when compiling a whole file. (eq (car form) 'custom-declare-group) (eq (car-safe name) 'quote)) (setq byte-compile-current-group (cadr name)))))) @@ -1252,50 +1314,54 @@ extra args." ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (form macrop) - (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) + (let* ((name (nth 1 form)) + (old (byte-compile-fdefinition name macrop))) (if (and old (not (eq old t))) (progn (and (eq 'macro (car-safe old)) (eq 'lambda (car-safe (cdr-safe old))) (setq old (cdr old))) (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (byte-code-function-p old) - (aref old 0) - '(&rest def))))) + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (t '(&rest def))))) (sig2 (byte-compile-arglist-signature (nth 2 form)))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position (nth 1 form)) + (byte-compile-set-symbol-position name) (byte-compile-warn "%s %s used to take %s %s, now takes %s" (if (eq (car form) 'defun) "function" "macro") - (nth 1 form) + name (byte-compile-arglist-signature-string sig1) (if (equal sig1 '(1 . 1)) "argument" "arguments") (byte-compile-arglist-signature-string sig2))))) ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) + (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) - (if calls - (progn - (setq sig (byte-compile-arglist-signature (nth 2 form)) - nums (sort (copy-sequence (cdr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position (nth 1 form)) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - (nth 1 form) - (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))))) - ))) + (when calls + (when (and (symbolp name) + (eq (get name 'byte-optimizer) + 'byte-compile-inline-expand)) + (byte-compile-warn "defsubst `%s' was used before it was defined" + name)) + (setq sig (byte-compile-arglist-signature (nth 2 form)) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + 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))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -1331,14 +1397,7 @@ extra args." ;; but such warnings are never useful, ;; so don't warn about them. 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))))) + cl-compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1401,7 +1460,7 @@ symbol itself." (if any-value (or (memq symbol byte-compile-const-variables) ;; FIXME: We should provide a less intrusive way to find out - ;; is a variable is "constant". + ;; if a variable is "constant". (and (boundp symbol) (condition-case nil (progn (set symbol (symbol-value symbol)) nil) @@ -1414,6 +1473,7 @@ symbol itself." ((byte-compile-const-symbol-p ,form)))) (defmacro byte-compile-close-variables (&rest body) + (declare (debug t)) (cons 'let (cons '(;; ;; Close over these variables to encapsulate the @@ -1444,6 +1504,7 @@ symbol itself." body))) (defmacro displaying-byte-compile-warnings (&rest body) + (declare (debug t)) `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) (warning-series-started (and (markerp warning-series) @@ -1481,41 +1542,33 @@ Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") (byte-recompile-directory directory nil t)) -;; The `bytecomp-' prefix is applied to all local variables with -;; otherwise common names in this and similar functions for the sake -;; of the boundp test in byte-compile-variable-ref. -;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html -;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html -;; Note that similar considerations apply to command-line-1 in startup.el. ;;;###autoload -(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg - bytecomp-force) - "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation. +(defun byte-recompile-directory (directory &optional arg force) + "Recompile every `.el' file in DIRECTORY that needs recompilation. This happens when a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of BYTECOMP-DIRECTORY are processed also. +Files in subdirectories of DIRECTORY are processed also. If the `.elc' file does not exist, normally this function *does not* compile the corresponding `.el' file. However, if the prefix argument -BYTECOMP-ARG is 0, that means do compile all those files. A nonzero -BYTECOMP-ARG means ask the user, for each such `.el' file, whether to -compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory +ARG is 0, that means do compile all those files. A nonzero +ARG means ask the user, for each such `.el' file, whether to +compile it. A nonzero ARG also means ask about each subdirectory before scanning it. -If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file +If the third argument FORCE is non-nil, recompile every `.el' file that already has a `.elc' file." (interactive "DByte recompile directory: \nP") - (if bytecomp-arg - (setq bytecomp-arg (prefix-numeric-value bytecomp-arg))) + (if arg (setq arg (prefix-numeric-value arg))) (if noninteractive nil (save-some-buffers) (force-mode-line-update)) (with-current-buffer (get-buffer-create byte-compile-log-buffer) - (setq default-directory (expand-file-name bytecomp-directory)) + (setq default-directory (expand-file-name directory)) ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) - (let ((bytecomp-directories (list default-directory)) + (let ((directories (list default-directory)) (default-directory default-directory) (skip-count 0) (fail-count 0) @@ -1523,47 +1576,36 @@ that already has a `.elc' file." (dir-count 0) last-dir) (displaying-byte-compile-warnings - (while bytecomp-directories - (setq bytecomp-directory (car bytecomp-directories)) - (message "Checking %s..." bytecomp-directory) - (let ((bytecomp-files (directory-files bytecomp-directory)) - bytecomp-source bytecomp-dest) - (dolist (bytecomp-file bytecomp-files) - (setq bytecomp-source - (expand-file-name bytecomp-file bytecomp-directory)) - (if (and (not (member bytecomp-file '("RCS" "CVS"))) - (not (eq ?\. (aref bytecomp-file 0))) - (file-directory-p bytecomp-source) - (not (file-symlink-p bytecomp-source))) - ;; This file is a subdirectory. Handle them differently. - (when (or (null bytecomp-arg) - (eq 0 bytecomp-arg) - (y-or-n-p (concat "Check " bytecomp-source "? "))) - (setq bytecomp-directories - (nconc bytecomp-directories (list bytecomp-source)))) - ;; It is an ordinary file. Decide whether to compile it. - (if (and (string-match emacs-lisp-file-regexp bytecomp-source) - (file-readable-p bytecomp-source) - (not (auto-save-file-name-p bytecomp-source)) - (not (string-equal dir-locals-file - (file-name-nondirectory - bytecomp-source)))) - (progn (let ((bytecomp-res (byte-recompile-file - bytecomp-source - bytecomp-force bytecomp-arg))) - (cond ((eq bytecomp-res 'no-byte-compile) - (setq skip-count (1+ skip-count))) - ((eq bytecomp-res t) - (setq file-count (1+ file-count))) - ((eq bytecomp-res nil) - (setq fail-count (1+ fail-count))))) - (or noninteractive - (message "Checking %s..." bytecomp-directory)) - (if (not (eq last-dir bytecomp-directory)) - (setq last-dir bytecomp-directory - dir-count (1+ dir-count))) - ))))) - (setq bytecomp-directories (cdr bytecomp-directories)))) + (while directories + (setq directory (car directories)) + (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)))) + ;; It is an ordinary file. Decide whether to compile it. + (if (and (string-match emacs-lisp-file-regexp source) + (file-readable-p source) + (not (auto-save-file-name-p source)) + (not (string-equal dir-locals-file + (file-name-nondirectory source)))) + (progn (case (byte-recompile-file source force arg) + (no-byte-compile (setq skip-count (1+ skip-count))) + ((t) (setq file-count (1+ file-count))) + ((nil) (setq fail-count (1+ fail-count)))) + (or noninteractive + (message "Checking %s..." directory)) + (if (not (eq last-dir directory)) + (setq last-dir directory + dir-count (1+ dir-count))) + ))))) + (setq directories (cdr directories)))) (message "Done (Total of %d file%s compiled%s%s%s)" file-count (if (= file-count 1) "" "s") (if (> fail-count 0) (format ", %d failed" fail-count) "") @@ -1575,104 +1617,100 @@ that already has a `.elc' file." "Non-nil to prevent byte-compiling of Emacs Lisp code. This is normally set in local file variables at the end of the elisp file: -;; Local Variables:\n;; no-byte-compile: t\n;; End: ") +\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) -(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) - "Recompile BYTECOMP-FILENAME file if it needs recompilation. +(defun byte-recompile-file (filename &optional force arg load) + "Recompile FILENAME file if it needs recompilation. This happens when its `.elc' file is older than itself. If the `.elc' file exists and is up-to-date, normally this -function *does not* compile BYTECOMP-FILENAME. However, if the -prefix argument BYTECOMP-FORCE is set, that means do compile -BYTECOMP-FILENAME even if the destination already exists and is +function *does not* compile FILENAME. However, if the +prefix argument FORCE is set, that means do compile +FILENAME even if the destination already exists and is up-to-date. If the `.elc' file does not exist, normally this function *does -not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means +not* compile FILENAME. If ARG is 0, that means compile the file even if it has never been compiled before. -A nonzero BYTECOMP-ARG means ask the user. +A nonzero ARG means ask the user. If LOAD is set, `load' the file after compiling. The value returned is the value returned by `byte-compile-file', or 'no-byte-compile if the file did not need recompilation." (interactive - (let ((bytecomp-file buffer-file-name) - (bytecomp-file-name nil) - (bytecomp-file-dir nil)) - (and bytecomp-file - (eq (cdr (assq 'major-mode (buffer-local-variables))) - 'emacs-lisp-mode) - (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) - bytecomp-file-dir (file-name-directory bytecomp-file))) + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) (list (read-file-name (if current-prefix-arg "Byte compile file: " "Byte recompile file: ") - bytecomp-file-dir bytecomp-file-name nil) + file-dir file-name nil) current-prefix-arg))) - (let ((bytecomp-dest - (byte-compile-dest-file bytecomp-filename)) + (let ((dest (byte-compile-dest-file filename)) ;; Expand now so we get the current buffer's defaults - (bytecomp-filename (expand-file-name bytecomp-filename))) - (if (if (file-exists-p bytecomp-dest) + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) ;; File was already compiled ;; Compile if forced to, or filename newer - (or bytecomp-force - (file-newer-than-file-p bytecomp-filename - bytecomp-dest)) - (and bytecomp-arg - (or (eq 0 bytecomp-arg) + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) (y-or-n-p (concat "Compile " - bytecomp-filename "? "))))) + filename "? "))))) (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." bytecomp-filename)) - (byte-compile-file bytecomp-filename load)) - (when load (load bytecomp-filename)) + (message "Compiling %s..." filename)) + (byte-compile-file filename load)) + (when load (load filename)) 'no-byte-compile))) ;;;###autoload -(defun byte-compile-file (bytecomp-filename &optional load) - "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. -The output file's name is generated by passing BYTECOMP-FILENAME to the +(defun byte-compile-file (filename &optional load) + "Compile a file of Lisp code named FILENAME into a file of byte code. +The output file's name is generated by passing FILENAME to the function `byte-compile-dest-file' (which see). With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. The value is non-nil if there were no errors, nil if errors." ;; (interactive "fByte compile file: \nP") (interactive - (let ((bytecomp-file buffer-file-name) - (bytecomp-file-name nil) - (bytecomp-file-dir nil)) - (and bytecomp-file - (eq (cdr (assq 'major-mode (buffer-local-variables))) - 'emacs-lisp-mode) - (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) - bytecomp-file-dir (file-name-directory bytecomp-file))) + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) (list (read-file-name (if current-prefix-arg "Byte compile and load file: " "Byte compile file: ") - bytecomp-file-dir bytecomp-file-name nil) + file-dir file-name nil) current-prefix-arg))) ;; Expand now so we get the current buffer's defaults - (setq bytecomp-filename (expand-file-name bytecomp-filename)) + (setq filename (expand-file-name filename)) ;; If we're compiling a file that's in a buffer and is modified, offer ;; to save it first. (or noninteractive - (let ((b (get-file-buffer (expand-file-name bytecomp-filename)))) + (let ((b (get-file-buffer (expand-file-name filename)))) (if (and b (buffer-modified-p b) (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) (with-current-buffer b (save-buffer))))) ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file bytecomp-filename) + (let ((byte-compile-current-file filename) (byte-compile-current-group nil) (set-auto-coding-for-load t) target-file input-buffer output-buffer byte-compile-dest-file) - (setq target-file (byte-compile-dest-file bytecomp-filename)) + (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) (with-current-buffer (setq input-buffer (get-buffer-create " *Compiler Input*")) @@ -1681,7 +1719,7 @@ The value is non-nil if there were no errors, nil if errors." ;; 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 bytecomp-filename) + (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) @@ -1691,7 +1729,7 @@ The value is non-nil if there were no errors, nil if errors." (set-buffer-multibyte nil)) ;; Run hooks including the uncompression hook. ;; If they change the file name, then change it for the output also. - (letf ((buffer-file-name bytecomp-filename) + (letf ((buffer-file-name filename) ((default-value 'major-mode) 'emacs-lisp-mode) ;; Ignore unsafe local variables. ;; We only care about a few of them for our purposes. @@ -1699,15 +1737,15 @@ The value is non-nil if there were no errors, nil if errors." (enable-local-eval nil)) ;; Arg of t means don't alter enable-local-variables. (normal-mode t) - (setq bytecomp-filename buffer-file-name)) + (setq filename buffer-file-name)) ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory bytecomp-filename))) + (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'" - ;; (file-relative-name bytecomp-filename) + ;; (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'" @@ -1717,18 +1755,18 @@ The value is non-nil if there were no errors, nil if errors." ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose - (message "Compiling %s..." bytecomp-filename)) + (message "Compiling %s..." filename)) (setq byte-compiler-error-flag nil) ;; 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 - (byte-compile-from-buffer input-buffer bytecomp-filename))) + (byte-compile-from-buffer input-buffer))) (if byte-compiler-error-flag nil (when byte-compile-verbose - (message "Compiling %s...done" bytecomp-filename)) + (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) @@ -1768,9 +1806,9 @@ The value is non-nil if there were no errors, nil if errors." (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? " - bytecomp-filename)))) + filename)))) (save-excursion - (display-call-tree bytecomp-filename))) + (display-call-tree filename))) (if load (load target-file)) t)))) @@ -1794,18 +1832,21 @@ With argument ARG, insert value in current buffer after the form." (let ((read-with-symbol-positions (current-buffer)) (read-symbol-positions-list nil)) (displaying-byte-compile-warnings - (byte-compile-sexp (read (current-buffer)))))))) + (byte-compile-sexp (read (current-buffer))))) + lexical-binding))) (cond (arg (message "Compiling from buffer... done.") (prin1 value (current-buffer)) (insert "\n")) ((message "%s" (prin1-to-string value))))))) +;; Dynamically bound in byte-compile-from-buffer. +;; NB also used in cl.el and cl-macs.el. +(defvar byte-compile--outbuffer) -(defun byte-compile-from-buffer (bytecomp-inbuffer &optional bytecomp-filename) - ;; Filename is used for the loading-into-Emacs-18 error message. - (let (bytecomp-outbuffer - (byte-compile-current-buffer bytecomp-inbuffer) +(defun byte-compile-from-buffer (inbuffer) + (let (byte-compile--outbuffer + (byte-compile-current-buffer inbuffer) (byte-compile-read-position nil) (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them @@ -1826,22 +1867,24 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-output nil) ;; This allows us to get the positions of symbols read; it's ;; new in Emacs 22.1. - (read-with-symbol-positions bytecomp-inbuffer) + (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) ) (byte-compile-close-variables (with-current-buffer - (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*")) + (setq byte-compile--outbuffer + (get-buffer-create " *Compiler Output*")) (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) (setq case-fold-search nil)) (displaying-byte-compile-warnings - (with-current-buffer bytecomp-inbuffer - (and bytecomp-filename - (byte-compile-insert-header bytecomp-filename bytecomp-outbuffer)) + (with-current-buffer inbuffer + (and byte-compile-current-file + (byte-compile-insert-header byte-compile-current-file + 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 @@ -1858,13 +1901,13 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((old-style-backquotes nil) - (form (read bytecomp-inbuffer))) + (form (read inbuffer))) ;; Warn about the use of old-style backquotes. (when old-style-backquotes (byte-compile-warn "!! The file uses old-style backquotes !! This functionality has been obsolete for more than 10 years already and will be removed soon. See (elisp)Backquote in the manual.")) - (byte-compile-file-form form))) + (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) ;; Make warnings about unresolved functions @@ -1873,10 +1916,10 @@ and will be removed soon. See (elisp)Backquote in the manual.")) (byte-compile-warn-about-unresolved-functions)) ;; Fix up the header at the front of the output ;; if the buffer contains multibyte characters. - (and bytecomp-filename - (with-current-buffer bytecomp-outbuffer - (byte-compile-fix-header bytecomp-filename))))) - bytecomp-outbuffer)) + (and byte-compile-current-file + (with-current-buffer byte-compile--outbuffer + (byte-compile-fix-header byte-compile-current-file))))) + byte-compile--outbuffer)) (defun byte-compile-fix-header (filename) "If the current buffer has any multibyte characters, insert a version test." @@ -1964,10 +2007,6 @@ Call from the source buffer." ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) -;; Dynamically bound in byte-compile-from-buffer. -;; NB also used in cl.el and cl-macs.el. -(defvar bytecomp-outbuffer) - (defun byte-compile-output-file-form (form) ;; writes the given form to the output buffer, being careful of docstrings ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and @@ -1975,8 +2014,8 @@ Call from the source buffer." ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. - (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst autoload - custom-declare-variable)) + (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst + autoload custom-declare-variable)) (stringp (nth 3 form))) (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil (memq (car form) @@ -1989,11 +2028,12 @@ Call from the source buffer." (print-gensym t) (print-circle ; handle circular data structures (not byte-compile-disable-print-circle))) - (princ "\n" bytecomp-outbuffer) - (prin1 form bytecomp-outbuffer) + (princ "\n" byte-compile--outbuffer) + (prin1 form byte-compile--outbuffer) nil))) (defvar print-gensym-alist) ;Used before print-circle existed. +(defvar byte-compile--for-effect) (defun byte-compile-output-docform (preface name info form specindex quoted) "Print a form with a doc string. INFO is (prefix doc-index postfix). @@ -2009,7 +2049,7 @@ list that represents a doc string reference. ;; 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 bytecomp-outbuffer + (with-current-buffer byte-compile--outbuffer (let (position) ;; Insert the doc string, and make it a comment with #@LENGTH. @@ -2033,7 +2073,7 @@ list that represents a doc string reference. (if preface (progn (insert preface) - (prin1 name bytecomp-outbuffer))) + (prin1 name byte-compile--outbuffer))) (insert (car info)) (let ((print-escape-newlines t) (print-quoted t) @@ -2048,7 +2088,7 @@ list that represents a doc string reference. (print-continuous-numbering t) print-number-table (index 0)) - (prin1 (car form) bytecomp-outbuffer) + (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) (insert " ") @@ -2059,7 +2099,7 @@ list that represents a doc string reference. ;; (for instance, gensyms in the arg list). (let (non-nil) (when (hash-table-p print-number-table) - (maphash (lambda (k v) (if v (setq non-nil t))) + (maphash (lambda (_k v) (if v (setq non-nil t))) print-number-table)) (not non-nil))) ;; Output the byte code and constants specially @@ -2068,37 +2108,40 @@ list that represents a doc string reference. (byte-compile-output-as-comment (cons (car form) (nth 1 form)) t))) - (setq position (- (position-bytes position) (point-min) -1)) - (princ (format "(#$ . %d) nil" position) bytecomp-outbuffer) + (setq position (- (position-bytes position) + (point-min) -1)) + (princ (format "(#$ . %d) nil" position) + byte-compile--outbuffer) (setq form (cdr form)) (setq index (1+ index)))) ((= index (nth 1 info)) (if position (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") position) - bytecomp-outbuffer) + byte-compile--outbuffer) (let ((print-escape-newlines nil)) (goto-char (prog1 (1+ (point)) - (prin1 (car form) bytecomp-outbuffer))) + (prin1 (car form) + byte-compile--outbuffer))) (insert "\\\n") (goto-char (point-max))))) (t - (prin1 (car form) bytecomp-outbuffer))))) + (prin1 (car form) byte-compile--outbuffer))))) (insert (nth 2 info))))) nil) -(defun byte-compile-keep-pending (form &optional bytecomp-handler) +(defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form t))) - (if bytecomp-handler - (let ((for-effect t)) + (if handler + (let ((byte-compile--for-effect t)) ;; To avoid consing up monstrously large forms at load time, we split ;; the output regularly. (and (memq (car-safe form) '(fset defalias)) (nthcdr 300 byte-compile-output) (byte-compile-flush-pending)) - (funcall bytecomp-handler form) - (if for-effect + (funcall handler form) + (if byte-compile--for-effect (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -2116,37 +2159,39 @@ list that represents a doc string reference. byte-compile-maxdepth 0 byte-compile-output nil)))) +(defun byte-compile-preprocess (form &optional _for-effect) + (setq form (macroexpand-all form byte-compile-macro-environment)) + ;; FIXME: We should run byte-optimize-form here, but it currently does not + ;; recurse through all the code, so we'd have to fix this first. + ;; Maybe a good fix would be to merge byte-optimize-form into + ;; macroexpand-all. + ;; (if (memq byte-optimize '(t source)) + ;; (setq form (byte-optimize-form form for-effect))) + (if lexical-binding + (cconv-closure-convert form) + form)) + +;; byte-hunk-handlers cannot call this! +(defun byte-compile-toplevel-file-form (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t)))) + +;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) + (let (handler) + (cond ((and (consp form) + (symbolp (car form)) + (setq handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, ;; so make-docfile can recognise them. Most other things can be output ;; as byte-code. -(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) -(defun byte-compile-file-form-defsubst (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. - nil) - (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) @@ -2200,7 +2245,8 @@ list that represents a doc string reference. (byte-compile-top-level (nth 2 form) nil 'file)))) form)) -(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) +(put 'define-abbrev-table 'byte-hunk-handler + 'byte-compile-file-form-define-abbrev-table) (defun byte-compile-file-form-define-abbrev-table (form) (if (eq 'quote (car-safe (car-safe (cdr form)))) (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) @@ -2298,51 +2344,49 @@ by side-effects." res)) (defun byte-compile-file-form-defmumble (form macrop) - (let* ((bytecomp-name (car (cdr form))) - (bytecomp-this-kind (if macrop 'byte-compile-macro-environment + (let* ((name (car (cdr form))) + (this-kind (if macrop 'byte-compile-macro-environment 'byte-compile-function-environment)) - (bytecomp-that-kind (if macrop 'byte-compile-function-environment + (that-kind (if macrop 'byte-compile-function-environment 'byte-compile-macro-environment)) - (bytecomp-this-one (assq bytecomp-name - (symbol-value bytecomp-this-kind))) - (bytecomp-that-one (assq bytecomp-name - (symbol-value bytecomp-that-kind))) + (this-one (assq name (symbol-value this-kind))) + (that-one (assq name (symbol-value that-kind))) (byte-compile-free-references nil) (byte-compile-free-assignments nil)) - (byte-compile-set-symbol-position bytecomp-name) + (byte-compile-set-symbol-position name) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq bytecomp-name byte-compile-call-tree) + (or (assq name byte-compile-call-tree) (setq byte-compile-call-tree - (cons (list bytecomp-name nil nil) byte-compile-call-tree)))) + (cons (list name nil nil) byte-compile-call-tree)))) - (setq byte-compile-current-form bytecomp-name) ; for warnings + (setq byte-compile-current-form name) ; for warnings (if (byte-compile-warning-enabled-p 'redefine) (byte-compile-arglist-warn form macrop)) (if byte-compile-verbose - ;; bytecomp-filename is from byte-compile-from-buffer. - (message "Compiling %s... (%s)" (or bytecomp-filename "") (nth 1 form))) - (cond (bytecomp-that-one + (message "Compiling %s... (%s)" + (or byte-compile-current-file "") (nth 1 form))) + (cond (that-one (if (and (byte-compile-warning-enabled-p 'redefine) ;; don't warn when compiling the stubs in byte-run... (not (assq (nth 1 form) byte-compile-initial-macro-environment))) (byte-compile-warn - "`%s' defined multiple times, as both function and macro" - (nth 1 form))) - (setcdr bytecomp-that-one nil)) - (bytecomp-this-one + "`%s' defined multiple times, as both function and macro" + (nth 1 form))) + (setcdr that-one nil)) + (this-one (when (and (byte-compile-warning-enabled-p 'redefine) - ;; hack: don't warn when compiling the magic internal - ;; byte-compiler macros in byte-run.el... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) + ;; hack: don't warn when compiling the magic internal + ;; byte-compiler macros in byte-run.el... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) (byte-compile-warn "%s `%s' defined multiple times in this file" (if macrop "macro" "function") (nth 1 form)))) - ((and (fboundp bytecomp-name) - (eq (car-safe (symbol-function bytecomp-name)) + ((and (fboundp name) + (eq (car-safe (symbol-function name)) (if macrop 'lambda 'macro))) (when (byte-compile-warning-enabled-p 'redefine) (byte-compile-warn "%s `%s' being redefined as a %s" @@ -2350,9 +2394,9 @@ by side-effects." (nth 1 form) (if macrop "macro" "function"))) ;; shadow existing definition - (set bytecomp-this-kind - (cons (cons bytecomp-name nil) - (symbol-value bytecomp-this-kind)))) + (set this-kind + (cons (cons name nil) + (symbol-value this-kind)))) ) (let ((body (nthcdr 3 form))) (when (and (stringp (car body)) @@ -2367,67 +2411,51 @@ by side-effects." ;; Remove declarations from the body of the macro definition. (when macrop (dolist (decl (byte-compile-defmacro-declaration form)) - (prin1 decl bytecomp-outbuffer))) - - (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t)) - (code (byte-compile-byte-code-maker new-one))) - (if bytecomp-this-one - (setcdr bytecomp-this-one new-one) - (set bytecomp-this-kind - (cons (cons bytecomp-name new-one) - (symbol-value bytecomp-this-kind)))) - (if (and (stringp (nth 3 form)) - (eq 'quote (car-safe code)) - (eq 'lambda (car-safe (nth 1 code)))) - (cons (car form) - (cons bytecomp-name (cdr (nth 1 code)))) - (byte-compile-flush-pending) - (if (not (stringp (nth 3 form))) - ;; No doc string. Provide -1 as the "doc string index" - ;; so that no element will be treated as a doc string. - (byte-compile-output-docform - "\n(defalias '" - bytecomp-name - (cond ((atom code) - (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) - ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) - (append code nil) - (and (atom code) byte-compile-dynamic - 1) - nil) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - bytecomp-name - (cond ((atom code) - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) - (append code nil) - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" bytecomp-outbuffer) - nil)))) + (prin1 decl byte-compile--outbuffer))) + + (let* ((code (byte-compile-lambda (nthcdr 2 form) t))) + (if this-one + (setcdr this-one code) + (set this-kind + (cons (cons name code) + (symbol-value this-kind)))) + (byte-compile-flush-pending) + (if (not (stringp (nth 3 form))) + ;; No doc string. Provide -1 as the "doc string index" + ;; so that no element will be treated as a doc string. + (byte-compile-output-docform + "\n(defalias '" + name + (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")) + (append code nil) ; Turn byte-code-function-p into list. + (and (atom code) byte-compile-dynamic + 1) + nil) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the defalias. + (byte-compile-output-docform + "\n(defalias '" + name + (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")) + (append code nil) ; Turn byte-code-function-p into list. + (and (atom code) byte-compile-dynamic + 1) + nil)) + (princ ")" byte-compile--outbuffer) + nil))) ;; Print Lisp object EXP in the output file, inside a comment, ;; and return the file position it will have. ;; 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 bytecomp-outbuffer + (with-current-buffer byte-compile--outbuffer ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted - (prin1 exp bytecomp-outbuffer) - (princ exp bytecomp-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. @@ -2469,6 +2497,10 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + ;; Get rid of the `function' quote added by the `lambda' macro. + (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2480,56 +2512,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." "Compile and return SEXP." (displaying-byte-compile-warnings (byte-compile-close-variables - (byte-compile-top-level sexp)))) - -;; Given a function made by byte-compile-lambda, make a form which produces it. -(defun byte-compile-byte-code-maker (fun) - (cond - ;; ## atom is faster than compiled-func-p. - ((atom fun) ; compiled function. - ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda - ;; would have produced a lambda. - fun) - ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial - ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off. - ((let (tmp) - (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) - (null (cdr (memq tmp fun)))) - ;; Generate a make-byte-code call. - (let* ((interactive (assq 'interactive (cdr (cdr fun))))) - (nconc (list 'make-byte-code - (list 'quote (nth 1 fun)) ;arglist - (nth 1 tmp) ;bytes - (nth 2 tmp) ;consts - (nth 3 tmp)) ;depth - (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc - (interactive - (list nil))) - (cond (interactive - (list (if (or (null (nth 1 interactive)) - (stringp (nth 1 interactive))) - (nth 1 interactive) - ;; Interactive spec is a list or a variable - ;; (if it is correct). - (list 'quote (nth 1 interactive)))))))) - ;; a non-compiled function (probably trivial) - (list 'quote fun)))))) - -;; Turn a function into an ordinary lambda. Needed for v18 files. -(defun byte-compile-byte-code-unmake (function) - (if (consp function) - function;;It already is a lambda. - (setq function (append function nil)) ; turn it into a list - (nconc (list 'lambda (nth 0 function)) - (and (nth 4 function) (list (nth 4 function))) - (if (nthcdr 5 function) - (list (cons 'interactive (if (nth 5 function) - (nthcdr 5 function))))) - (list (list 'byte-code - (nth 1 function) (nth 2 function) - (nth 3 function)))))) - + (byte-compile-top-level (byte-compile-preprocess sexp))))) (defun byte-compile-check-lambda-list (list) "Check lambda-list LIST for errors." @@ -2556,6 +2539,44 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + +(defun byte-compile-make-lambda-lexenv (form) + "Return a new lexical environment for a lambda expression FORM." + ;; See if this is a closure or not + (let ((args (byte-compile-arglist-vars (cadr form)))) + (let ((lexenv nil)) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + ;; Add entries for each argument + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + +(defun byte-compile-make-args-desc (arglist) + (let ((mandatory 0) + nonrest (rest 0)) + (while (and arglist (not (memq (car arglist) '(&optional &rest)))) + (setq mandatory (1+ mandatory)) + (setq arglist (cdr arglist))) + (setq nonrest mandatory) + (when (eq (car arglist) '&optional) + (setq arglist (cdr arglist)) + (while (and arglist (not (eq (car arglist) '&rest))) + (setq nonrest (1+ nonrest)) + (setq arglist (cdr arglist)))) + (when arglist + (setq rest 1)) + (if (> mandatory 127) + (byte-compile-report-error "Too many (>127) mandatory arguments") + (logior mandatory + (lsh nonrest 8) + (lsh rest 7))))) + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2563,78 +2584,87 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; of the list FUN and `byte-compile-set-symbol-position' is not called. ;; Use this feature to avoid calling `byte-compile-set-symbol-position' ;; for symbols generated by the byte compiler itself. -(defun byte-compile-lambda (bytecomp-fun &optional add-lambda) +(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) (if add-lambda - (setq bytecomp-fun (cons 'lambda bytecomp-fun)) - (unless (eq 'lambda (car-safe bytecomp-fun)) - (error "Not a lambda list: %S" bytecomp-fun)) + (setq fun (cons 'lambda fun)) + (unless (eq 'lambda (car-safe fun)) + (error "Not a lambda list: %S" fun)) (byte-compile-set-symbol-position 'lambda)) - (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) - (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) + (byte-compile-check-lambda-list (nth 1 fun)) + (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables - (nconc (and (byte-compile-warning-enabled-p 'free-vars) - (delq '&rest - (delq '&optional (copy-sequence bytecomp-arglist)))) - byte-compile-bound-variables)) - (bytecomp-body (cdr (cdr bytecomp-fun))) - (bytecomp-doc (if (stringp (car bytecomp-body)) - (prog1 (car bytecomp-body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr bytecomp-body) - (setq bytecomp-body (cdr bytecomp-body)))))) - (bytecomp-int (assq 'interactive bytecomp-body))) + (append (and (not lexical-binding) + (byte-compile-arglist-vars arglist)) + byte-compile-bound-variables)) + (body (cdr (cdr fun))) + (doc (if (stringp (car body)) + (prog1 (car body) + ;; Discard the doc string + ;; unless it is the last element of the body. + (if (cdr body) + (setq body (cdr body)))))) + (int (assq 'interactive body))) ;; Process the interactive spec. - (when bytecomp-int + (when int (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). - (if (eq bytecomp-int (car bytecomp-body)) - (setq bytecomp-body (cdr bytecomp-body))) - (cond ((consp (cdr bytecomp-int)) - (if (cdr (cdr bytecomp-int)) + (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 bytecomp-int))) + (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 bytecomp-int))) + (let* ((form (nth 1 int)) + (newform (byte-compile-top-level form))) (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 bytecomp-int)) - (setq bytecomp-int (list 'interactive - (byte-compile-top-level - (nth 1 bytecomp-int))))))) - ((cdr bytecomp-int) + (if (and (eq (car-safe form) 'list) + ;; The spec is evaled in callint.c in dynamic-scoping + ;; mode, so just leaving the form unchanged would mean + ;; it won't be eval'd in the right mode. + (not lexical-binding)) + nil + (setq int `(interactive ,newform))))) + ((cdr int) (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string bytecomp-int))))) + (prin1-to-string int))))) ;; Process the body. - (let ((compiled (byte-compile-top-level - (cons 'progn bytecomp-body) nil 'lambda))) + (let ((compiled + (byte-compile-top-level (cons 'progn body) nil 'lambda + ;; If doing lexical binding, push a new + ;; lexical environment containing just the + ;; args (since lambda expressions should be + ;; closed by now). + (and lexical-binding + (byte-compile-make-lambda-lexenv fun)) + reserved-csts))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) - (setq compiled - (nconc (if bytecomp-int (list bytecomp-int)) - (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) - (compiled (list compiled))))) - (nconc (list 'lambda bytecomp-arglist) - (if (or bytecomp-doc (stringp (car compiled))) - (cons bytecomp-doc (cond (compiled) - (bytecomp-body (list nil)))) - compiled)))))) + (apply 'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond (lexical-binding + (require 'help-fns) + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int))))) + (error "byte-compile-top-level did not return byte-code"))))) + +(defvar byte-compile-reserved-constants 0) (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. @@ -2644,7 +2674,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Next up to byte-constant-limit are constants, still with one-byte codes. ;; Next variables again, to get 2-byte codes for variable lookup. ;; The rest of the constants and variables need 3-byte byte-codes. - (let* ((i -1) + (let* ((i (1- byte-compile-reserved-constants)) (rest (nreverse byte-compile-variables)) ; nreverse because the first (other (nreverse byte-compile-constants)) ; vars often are used most. ret tmp @@ -2655,11 +2685,15 @@ If FORM is a lambda or a macro, byte-compile it as a function." limit) (while (or rest other) (setq limit (car limits)) - (while (and rest (not (eq i limit))) - (if (setq tmp (assq (car (car rest)) ret)) - (setcdr (car rest) (cdr tmp)) + (while (and rest (< i limit)) + (cond + ((numberp (car rest)) + (assert (< (car rest) byte-compile-reserved-constants))) + ((setq tmp (assq (car (car rest)) ret)) + (setcdr (car rest) (cdr tmp))) + (t (setcdr (car rest) (setq i (1+ i))) - (setq ret (cons (car rest) ret))) + (setq ret (cons (car rest) ret)))) (setq rest (cdr rest))) (setq limits (cdr limits) rest (prog1 other @@ -2668,29 +2702,38 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given an expression FORM, compile it and return an equivalent byte-code ;; expression (a call to the function byte-code). -(defun byte-compile-top-level (form &optional for-effect output-type) +(defun byte-compile-top-level (form &optional for-effect output-type + lexenv reserved-csts) ;; OUTPUT-TYPE advises about how form is expected to be used: ;; 'eval or nil -> a single form, ;; 'progn or t -> a list of forms, ;; 'lambda -> body of a lambda, ;; 'file -> used at file-level. - (let ((byte-compile-constants nil) + (let ((byte-compile--for-effect for-effect) + (byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) + (byte-compile--lexical-environment lexenv) + (byte-compile-reserved-constants (or reserved-csts 0)) (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form byte-compile--for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + ;; Set up things for a lexically-bound function. + (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)) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer. + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag)))) + ;; Now compile FORM + (byte-compile-form form byte-compile--for-effect) + (byte-compile-out-toplevel byte-compile--for-effect output-type))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2712,7 +2755,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq byte-compile-output (nreverse byte-compile-output)) (if (memq byte-optimize '(t byte)) (setq byte-compile-output - (byte-optimize-lapcode byte-compile-output for-effect))) + (byte-optimize-lapcode byte-compile-output))) ;; Decompile trivial functions: ;; only constants and variables, or a single funcall except in lambdas. @@ -2740,34 +2783,35 @@ If FORM is a lambda or a macro, byte-compile it as a function." (progn (setq rest (nreverse (cdr (memq tmp (reverse byte-compile-output))))) - (while (cond - ((memq (car (car rest)) '(byte-varref byte-constant)) - (setq tmp (car (cdr (car rest)))) - (if (if (eq (car (car rest)) 'byte-constant) - (or (consp tmp) - (and (symbolp tmp) - (not (byte-compile-const-symbol-p tmp))))) - (if maycall - (setq body (cons (list 'quote tmp) body))) - (setq body (cons tmp body)))) - ((and maycall - ;; Allow a funcall if at most one atom follows it. - (null (nthcdr 3 rest)) - (setq tmp (get (car (car rest)) 'byte-opcode-invert)) - (or (null (cdr rest)) - (and (memq output-type '(file progn t)) - (cdr (cdr rest)) - (eq (car (nth 1 rest)) 'byte-discard) - (progn (setq rest (cdr rest)) t)))) - (setq maycall nil) ; Only allow one real function call. - (setq body (nreverse body)) - (setq body (list - (if (and (eq tmp 'funcall) - (eq (car-safe (car body)) 'quote)) - (cons (nth 1 (car body)) (cdr body)) - (cons tmp body)))) - (or (eq output-type 'file) - (not (delq nil (mapcar 'consp (cdr (car body)))))))) + (while + (cond + ((memq (car (car rest)) '(byte-varref byte-constant)) + (setq tmp (car (cdr (car rest)))) + (if (if (eq (car (car rest)) 'byte-constant) + (or (consp tmp) + (and (symbolp tmp) + (not (byte-compile-const-symbol-p tmp))))) + (if maycall + (setq body (cons (list 'quote tmp) body))) + (setq body (cons tmp body)))) + ((and maycall + ;; Allow a funcall if at most one atom follows it. + (null (nthcdr 3 rest)) + (setq tmp (get (car (car rest)) 'byte-opcode-invert)) + (or (null (cdr rest)) + (and (memq output-type '(file progn t)) + (cdr (cdr rest)) + (eq (car (nth 1 rest)) 'byte-discard) + (progn (setq rest (cdr rest)) t)))) + (setq maycall nil) ; Only allow one real function call. + (setq body (nreverse body)) + (setq body (list + (if (and (eq tmp 'funcall) + (eq (car-safe (car body)) 'quote)) + (cons (nth 1 (car body)) (cdr body)) + (cons tmp body)))) + (or (eq output-type 'file) + (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) (let ((byte-compile-vector (byte-compile-constants-vector))) @@ -2777,94 +2821,108 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((cdr body) (cons 'progn (nreverse body))) ((car body))))) -;; Given BYTECOMP-BODY, compile it and return a new body. -(defun byte-compile-top-level-body (bytecomp-body &optional for-effect) - (setq bytecomp-body - (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) - (cond ((eq (car-safe bytecomp-body) 'progn) - (cdr bytecomp-body)) - (bytecomp-body - (list bytecomp-body)))) - -(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) -(defun byte-compile-declare-function (form) - (push (cons (nth 1 form) - (if (and (> (length form) 3) - (listp (nth 3 form))) - (list 'declared (nth 3 form)) +;; Given BODY, compile it and return a new body. +(defun byte-compile-top-level-body (body &optional for-effect) + (setq body + (byte-compile-top-level (cons 'progn body) for-effect t)) + (cond ((eq (car-safe body) 'progn) + (cdr body)) + (body + (list body)))) + +;; Special macro-expander used during byte-compilation. +(defun byte-compile-macroexpand-declare-function (fn file &rest args) + (push (cons fn + (if (and (consp args) (listp (car args))) + (list 'declared (car args)) t)) ; arglist not specified byte-compile-function-environment) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions - (delq (nth 1 form) byte-compile-noruntime-functions)) - nil) + (delq fn byte-compile-noruntime-functions)) + ;; Delegate the rest to the normal macro definition. + (macroexpand `(declare-function ,fn ,file ,@args))) ;; This is the recursive entry point for compiling each subform of an ;; expression. ;; If for-effect is non-nil, byte-compile-form will output a byte-discard ;; before terminating (ie no value will be left on the stack). -;; A byte-compile handler may, when for-effect is non-nil, choose output code -;; which does not leave a value on the stack, and then set for-effect to nil -;; (to prevent byte-compile-form from outputting the byte-discard). +;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose +;; output code which does not leave a value on the stack, and then set +;; byte-compile--for-effect to nil (to prevent byte-compile-form from +;; outputting the byte-discard). ;; If a handler wants to call another handler, it should do so via -;; byte-compile-form, or take extreme care to handle for-effect correctly. -;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) +;; byte-compile-form, or take extreme care to handle byte-compile--for-effect +;; correctly. (Use byte-compile-form-do-effect to reset the +;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) - (cond ((not (consp form)) - (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) - (when (symbolp form) - (byte-compile-set-symbol-position form)) - (byte-compile-constant form)) - ((and for-effect byte-compile-delete-errors) - (when (symbolp form) - (byte-compile-set-symbol-position form)) - (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) - ((symbolp (car form)) - (let* ((bytecomp-fn (car form)) - (bytecomp-handler (get bytecomp-fn 'byte-compile))) - (when (byte-compile-const-symbol-p bytecomp-fn) - (byte-compile-warn "`%s' called as a function" bytecomp-fn)) - (and (byte-compile-warning-enabled-p 'interactive-only) - (memq bytecomp-fn byte-compile-interactive-only-functions) - (byte-compile-warn "`%s' used from Lisp code\n\ -That command is designed for interactive use only" bytecomp-fn)) - (when (byte-compile-warning-enabled-p 'callargs) - (if (memq bytecomp-fn - '(custom-declare-group custom-declare-variable - custom-declare-face)) - (byte-compile-nogroup-warn form)) - (byte-compile-callargs-warn form)) - (if (and bytecomp-handler - ;; Make sure that function exists. This is important - ;; for CL compiler macros since the symbol may be - ;; `cl-byte-compile-compiler-macro' but if CL isn't - ;; loaded, this function doesn't exist. - (or (not (memq bytecomp-handler - '(cl-byte-compile-compiler-macro))) - (functionp bytecomp-handler))) - (funcall bytecomp-handler form) - (byte-compile-normal-call form)) - (if (byte-compile-warning-enabled-p 'cl-functions) - (byte-compile-cl-warn form)))) - ((and (or (byte-code-function-p (car form)) - (eq (car-safe (car form)) 'lambda)) - ;; if the form comes out the same way it went in, that's - ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) - (byte-compile-form form for-effect) - (setq for-effect nil)) - ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) + (let ((byte-compile--for-effect for-effect)) + (cond + ((not (consp form)) + (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) + (when (symbolp form) + (byte-compile-set-symbol-position form)) + (byte-compile-constant form)) + ((and byte-compile--for-effect byte-compile-delete-errors) + (when (symbolp form) + (byte-compile-set-symbol-position form)) + (setq byte-compile--for-effect nil)) + (t + (byte-compile-variable-ref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile))) + (when (byte-compile-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)) + (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)))) + (if (and handler + ;; Make sure that function exists. This is important + ;; for CL compiler macros since the symbol may be + ;; `cl-byte-compile-compiler-macro' but if CL isn't + ;; loaded, this function doesn't exist. + (and (not (eq handler + ;; Already handled by macroexpand-all. + 'cl-byte-compile-compiler-macro)) + (functionp handler))) + (funcall handler form) + (byte-compile-normal-call form)) + (if (byte-compile-warning-enabled-p 'cl-functions) + (byte-compile-cl-warn form)))) + ((and (byte-code-function-p (car form)) + (memq byte-optimize '(t lap))) + (byte-compile-unfold-bcf form)) + ((and (eq (car-safe (car form)) 'lambda) + ;; if the form comes out the same way it went in, that's + ;; because it was malformed, and we couldn't unfold it. + (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (byte-compile-form form byte-compile--for-effect) + (setq byte-compile--for-effect nil)) + ((byte-compile-normal-call form))) + (if byte-compile--for-effect + (byte-compile-discard)))) (defun byte-compile-normal-call (form) + (when (and (byte-compile-warning-enabled-p 'callargs) + (symbolp (car form))) + (if (memq (car 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)) - (when (and for-effect (eq (car form) 'mapcar) + (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar)) (byte-compile-set-symbol-position 'mapcar) (byte-compile-warn @@ -2873,44 +2931,142 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (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 bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) + +;; Splice the given lap code into the current instruction stream. +;; If it has any labels in it, you're responsible for making sure there +;; are no collisions, and that byte-compile-tag-number is reasonable +;; after this is spliced in. The provided list is destroyed. +(defun byte-compile-inline-lapcode (lap end-depth) + ;; "Replay" the operations: we used to just do + ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)) + ;; but that fails to update byte-compile-depth, so we had to assume + ;; that `lap' ends up adding exactly 1 element to the stack. This + ;; happens to be true for byte-code generated by bytecomp.el without + ;; lexical-binding, but it's not true in general, and it's not true for + ;; code output by bytecomp.el with lexical-binding. + (let ((endtag (byte-compile-make-tag))) + (dolist (op lap) + (cond + ((eq (car op) 'TAG) (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + ((eq (car op) 'byte-return) + (byte-compile-discard (- byte-compile-depth end-depth) t) + (byte-compile-goto 'byte-goto endtag)) + (t (byte-compile-out (car op) (cdr op))))) + (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)) + (start-depth byte-compile-depth) + (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest. + ;; (fmin (if (numberp fargs) (logand fargs 127))) + (alen (length (cdr form))) + (dynbinds ())) + (fetch-bytecode fun) + (mapc 'byte-compile-form (cdr form)) + (unless fmax2 + ;; Old-style byte-code. + (assert (listp fargs)) + (while fargs + (case (car fargs) + (&optional (setq fargs (cdr fargs))) + (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1)) + (push (cadr fargs) dynbinds) + (setq fargs nil)) + (t (push (pop fargs) dynbinds)))) + (unless fmax2 (setq fmax2 (* 2 (length dynbinds))))) + (cond + ((<= (+ alen alen) fmax2) + ;; Add missing &optional (or &rest) arguments. + (dotimes (i (- (/ (1+ fmax2) 2) alen)) + (byte-compile-push-constant nil))) + ((zerop (logand fmax2 1)) + (byte-compile-log-warning "Too many arguments for inlined function" + nil :error) + (byte-compile-discard (- alen (/ fmax2 2)))) + (t + ;; Turn &rest args into a list. + (let ((n (- alen (/ (1- fmax2) 2)))) + (assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n) + (if (< n 5) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n)) + 0) + (byte-compile-out 'byte-listN n))))) + (mapc #'byte-compile-dynamic-variable-bind dynbinds) + (byte-compile-inline-lapcode + (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t) + (1+ start-depth)) + ;; Unbind dynamic variables. + (when dynbinds + (byte-compile-out 'byte-unbind (length dynbinds))) + (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." + (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 + "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))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(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) + (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))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-ref (cdr lex-binding)) + ;; VAR is dynamically bound + (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 "reference to free variable `%S'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(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))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-set (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2923,20 +3079,20 @@ That command is designed for interactive use only" bytecomp-fn)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants))))) -;; Use this when the value of a form is a constant. This obeys for-effect. +;; Use this when the value of a form is a constant. +;; This obeys byte-compile--for-effect. (defun byte-compile-constant (const) - (if for-effect - (setq for-effect nil) + (if byte-compile--for-effect + (setq byte-compile--for-effect nil) (when (symbolp const) (byte-compile-set-symbol-position const)) (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) ;; Use this for a constant that is not the value of its containing form. -;; This ignores for-effect. +;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (let ((for-effect nil)) + (let ((byte-compile--for-effect nil)) (inline (byte-compile-constant const)))) - ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3007,7 +3163,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) ;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler interactive-p 0) +;; (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) @@ -3090,7 +3246,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-warn "`%s' called with %d arg%s, but requires %s" (car form) (length (cdr form)) (if (= 1 (length (cdr form))) "" "s") n) - ;; get run-time wrong-number-of-args error. + ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) (defun byte-compile-no-args (form) @@ -3137,12 +3293,66 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) -(defun byte-compile-noop (form) +(defun byte-compile-noop (_form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) - +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack. +NUM defaults to 1. +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(defun byte-compile-stack-ref (stack-pos) + "Output byte codes to push the value at stack position STACK-POS." + (let ((dist (- byte-compile-depth (1+ stack-pos)))) + (if (zerop dist) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref dist)))) + +(defun byte-compile-stack-set (stack-pos) + "Output byte codes to store the TOS value at stack position STACK-POS." + (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) + +(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure) +(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) + +(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)) + (body (nthcdr 3 form)) + (fun + (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (assert (byte-code-function-p fun)) + (byte-compile-form `(make-byte-code + ',(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 (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 @@ -3297,43 +3507,17 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-warn "A quoted lambda form is the second argument of `fset'. This is probably not what you want, as that lambda cannot be compiled. Consider using - the syntax (function (lambda (...) ...)) instead."))))) + the syntax #'(lambda (...) ...) instead."))))) (byte-compile-two-args form)) -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (byte-compile-constant (if (symbolp (nth 1 form)) + (nth 1 form) + (byte-compile-lambda (nth 1 form))))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3368,20 +3552,19 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 setq) (byte-defop-compiler-1 setq-default) (byte-defop-compiler-1 quote) -(byte-defop-compiler-1 quote-form) (defun byte-compile-setq (form) - (let ((bytecomp-args (cdr form))) - (if bytecomp-args - (while bytecomp-args - (byte-compile-form (car (cdr bytecomp-args))) - (or for-effect (cdr (cdr bytecomp-args)) + (let ((args (cdr form))) + (if args + (while args + (byte-compile-form (car (cdr args))) + (or byte-compile--for-effect (cdr (cdr args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) + (byte-compile-variable-set (car args)) + (setq args (cdr (cdr args)))) ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) + (byte-compile-form nil byte-compile--for-effect)) + (setq byte-compile--for-effect nil))) (defun byte-compile-setq-default (form) (setq form (cdr form)) @@ -3412,26 +3595,22 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) - -(defun byte-compile-quote-form (form) - (byte-compile-constant (byte-compile-top-level (nth 1 form)))) - ;;; control structures -(defun byte-compile-body (bytecomp-body &optional for-effect) - (while (cdr bytecomp-body) - (byte-compile-form (car bytecomp-body) t) - (setq bytecomp-body (cdr bytecomp-body))) - (byte-compile-form (car bytecomp-body) for-effect)) +(defun byte-compile-body (body &optional for-effect) + (while (cdr body) + (byte-compile-form (car body) t) + (setq body (cdr body))) + (byte-compile-form (car body) for-effect)) -(defsubst byte-compile-body-do-effect (bytecomp-body) - (byte-compile-body bytecomp-body for-effect) - (setq for-effect nil)) +(defsubst byte-compile-body-do-effect (body) + (byte-compile-body body byte-compile--for-effect) + (setq byte-compile--for-effect nil)) (defsubst byte-compile-form-do-effect (form) - (byte-compile-form form for-effect) - (setq for-effect nil)) + (byte-compile-form form byte-compile--for-effect) + (setq byte-compile--for-effect nil)) (byte-defop-compiler-1 inline byte-compile-progn) (byte-defop-compiler-1 progn) @@ -3443,18 +3622,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 or) (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) +(byte-defop-compiler-1 let* byte-compile-let) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) @@ -3519,13 +3688,11 @@ that suppresses all warnings during execution of BODY." ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound-list - (append bound-list byte-compile-bound-variables) - byte-compile-bound-variables))) + (append bound-list byte-compile-bound-variables))) (unwind-protect - ;; If things not being bound at all is ok, so must them being obsolete. - ;; Note that we add to the existing lists since Tramp (ab)uses - ;; this feature. + ;; If things not being bound at all is ok, so must them being + ;; obsolete. Note that we add to the existing lists since Tramp + ;; (ab)uses this feature. (let ((byte-compile-not-obsolete-vars (append byte-compile-not-obsolete-vars bound-list)) (byte-compile-not-obsolete-funcs @@ -3547,20 +3714,20 @@ that suppresses all warnings during execution of BODY." (if (null (nthcdr 3 form)) ;; No else-forms (progn - (byte-compile-goto-if nil for-effect donetag) + (byte-compile-goto-if nil byte-compile--for-effect donetag) (byte-compile-maybe-guarded clause - (byte-compile-form (nth 2 form) for-effect)) + (byte-compile-form (nth 2 form) byte-compile--for-effect)) (byte-compile-out-tag donetag)) (let ((elsetag (byte-compile-make-tag))) (byte-compile-goto 'byte-goto-if-nil elsetag) (byte-compile-maybe-guarded clause - (byte-compile-form (nth 2 form) for-effect)) + (byte-compile-form (nth 2 form) byte-compile--for-effect)) (byte-compile-goto 'byte-goto donetag) (byte-compile-out-tag elsetag) (byte-compile-maybe-guarded (list 'not clause) - (byte-compile-body (cdr (cdr (cdr form))) for-effect)) + (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect)) (byte-compile-out-tag donetag)))) - (setq for-effect nil)) + (setq byte-compile--for-effect nil)) (defun byte-compile-cond (clauses) (let ((donetag (byte-compile-make-tag)) @@ -3577,18 +3744,18 @@ that suppresses all warnings during execution of BODY." (byte-compile-form (car clause)) (if (null (cdr clause)) ;; First clause is a singleton. - (byte-compile-goto-if t for-effect donetag) + (byte-compile-goto-if t byte-compile--for-effect donetag) (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-body (cdr clause) byte-compile--for-effect)) (byte-compile-goto 'byte-goto donetag) (byte-compile-out-tag nexttag))))) ;; Last 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) + (byte-compile-goto-if nil byte-compile--for-effect donetag) (setq clause (cdr clause)))) (byte-compile-maybe-guarded guard (byte-compile-body-do-effect clause))) @@ -3596,10 +3763,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect t) - (byte-compile-and-recursion bytecomp-args failtag)))) + (byte-compile-and-recursion args failtag)))) ;; Handle compilation of a nontrivial `and' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -3607,7 +3774,7 @@ that suppresses all warnings during execution of BODY." (if (cdr rest) (progn (byte-compile-form (car rest)) - (byte-compile-goto-if nil for-effect failtag) + (byte-compile-goto-if nil byte-compile--for-effect failtag) (byte-compile-maybe-guarded (car rest) (byte-compile-and-recursion (cdr rest) failtag))) (byte-compile-form-do-effect (car rest)) @@ -3615,10 +3782,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-or (form) (let ((wintag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect nil) - (byte-compile-or-recursion bytecomp-args wintag)))) + (byte-compile-or-recursion args wintag)))) ;; Handle compilation of a nontrivial `or' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -3626,7 +3793,7 @@ that suppresses all warnings during execution of BODY." (if (cdr rest) (progn (byte-compile-form (car rest)) - (byte-compile-goto-if t for-effect wintag) + (byte-compile-goto-if t byte-compile--for-effect wintag) (byte-compile-maybe-guarded (list 'not (car rest)) (byte-compile-or-recursion (cdr rest) wintag))) (byte-compile-form-do-effect (car rest)) @@ -3637,44 +3804,131 @@ that suppresses all warnings during execution of BODY." (looptag (byte-compile-make-tag))) (byte-compile-out-tag looptag) (byte-compile-form (car (cdr form))) - (byte-compile-goto-if nil for-effect endtag) + (byte-compile-goto-if nil byte-compile--for-effect endtag) (byte-compile-body (cdr (cdr form)) t) (byte-compile-goto 'byte-goto looptag) (byte-compile-out-tag endtag) - (setq for-effect nil))) + (setq byte-compile--for-effect nil))) (defun byte-compile-funcall (form) (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +(defun byte-compile-push-binding-init (clause) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +Return the offset in the form (VAR . OFFSET)." + (let* ((var (if (consp clause) (car clause) clause))) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (prog1 (cons var byte-compile-depth) + (if (consp clause) + (byte-compile-form (cadr clause)) + (byte-compile-push-constant nil))))) + +(defun byte-compile-not-lexical-var-p (var) + (or (not (symbolp var)) + (special-variable-p var) + (memq var byte-compile-bound-variables) + (memq var '(nil t)) + (keywordp var))) + +(defun byte-compile-bind (var init-lexenv) + "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." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, to move them to TOS for + ;; dynamic binding. + (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) + nil) + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + 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))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (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))))) - (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))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (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)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (init-lexenv nil)) + (when (eq (car form) 'let) + ;; First compute the binding values in the old scope. + (dolist (var clauses) + (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)) + ;; 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 + ;; values are now in reverse order on the stack. + (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) + (unless (eq (car form) 'let) + (push (byte-compile-push-binding-init var) init-lexenv)) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv) + (pop init-lexenv))))) + ;; Emit the body. + (let ((init-stack-depth byte-compile-depth)) + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (progn + (assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv (> byte-compile-depth + init-stack-depth))) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length clauses))))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3706,70 +3960,86 @@ that suppresses all warnings during execution of BODY." (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) -(byte-defop-compiler-1 with-output-to-temp-buffer) +;; (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) (byte-compile-form (car (cdr form))) - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) + (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) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr (cdr form)) t)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list (list 'funcall ,f)))) + (handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers t)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-track-mouse (form) (byte-compile-form - `(funcall '(lambda nil - (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) + (pcase form + (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) + (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var (cons var byte-compile-bound-variables) + (fun-bodies (eq var :fun-body)) + (byte-compile-bound-variables + (if (and var (not fun-bodies)) + (cons var byte-compile-bound-variables) byte-compile-bound-variables))) (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)) + (if fun-bodies (setq var (make-symbol "err"))) (byte-compile-push-constant var) - (byte-compile-push-constant (byte-compile-top-level - (nth 2 form) for-effect)) - (let ((clauses (cdr (cdr (cdr form)))) - compiled-clauses) - (while clauses - (let* ((clause (car clauses)) - (condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((syms condition) (ok t)) - (while syms - (if (not (symbolp (car syms))) - (setq ok nil)) - (setq syms (cdr syms))) - ok)))) - (byte-compile-warn - "`%s' is not a condition name or list of such (in condition-case)" - (prin1-to-string condition))) -;; ((not (or (eq condition 't) -;; (and (stringp (get condition 'error-message)) -;; (consp (get condition 'error-conditions))))) -;; (byte-compile-warn -;; "`%s' is not a known condition name (in condition-case)" -;; condition)) - ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) - (setq clauses (cdr clauses))) - (byte-compile-push-constant (nreverse compiled-clauses))) + (if fun-bodies + (byte-compile-form `(list 'funcall ,(nth 2 form))) + (byte-compile-push-constant + (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) + (let ((compiled-clauses + (mapcar + (lambda (clause) + (let ((condition (car clause))) + (cond ((not (or (symbolp condition) + (and (listp condition) + (let ((ok t)) + (dolist (sym condition) + (if (not (symbolp sym)) + (setq ok nil))) + ok)))) + (byte-compile-warn + "`%S' is not a condition name or list of such (in condition-case)" + condition)) + ;; (not (or (eq condition 't) + ;; (and (stringp (get condition 'error-message)) + ;; (consp (get condition + ;; 'error-conditions))))) + ;; (byte-compile-warn + ;; "`%s' is not a known condition name + ;; (in condition-case)" + ;; condition)) + ) + (if fun-bodies + `(list ',condition (list 'funcall ,(cadr clause) ',var)) + (cons condition + (byte-compile-top-level-body + (cdr clause) byte-compile--for-effect))))) + (cdr (cdr (cdr form)))))) + (if fun-bodies + (byte-compile-form `(list ,@compiled-clauses)) + (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) @@ -3791,17 +4061,6 @@ that suppresses all warnings during execution of BODY." (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-window-excursion (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr form) for-effect)) - (byte-compile-out 'byte-save-window-excursion 0)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr 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)) ;;; top-level forms elsewhere @@ -3818,22 +4077,16 @@ that suppresses all warnings during execution of BODY." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - ;; 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 (cdr (cdr form)) t))) - t) - (byte-compile-constant (nth 1 form))) + (byte-compile-push-constant 'defalias) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-push-constant (byte-compile-lambda (cdr (cdr form)) t)) + (byte-compile-out 'byte-call 2)) (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. (byte-compile-body-do-effect (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) + (code (byte-compile-lambda (cdr (cdr form)) t))) `((defalias ',(nth 1 form) ,(if (eq (car-safe code) 'make-byte-code) `(cons 'macro ,code) @@ -3881,7 +4134,7 @@ that suppresses all warnings during execution of BODY." ;; Put the defined variable in this library's load-history entry ;; just as a real defvar would, but only in top-level forms. (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) + `(setq current-load-list (cons ',var current-load-list))) (when (> (length form) 3) (when (and string (not (stringp string))) (byte-compile-warn "third arg to `%s %s' is not a string: %s" @@ -3915,7 +4168,7 @@ that suppresses all warnings during execution of BODY." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. -(defun byte-compile-lambda-form (form) +(defun byte-compile-lambda-form (_form) (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) @@ -3990,8 +4243,8 @@ that suppresses all warnings during execution of BODY." (progn ;; ## remove this someday (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) @@ -4003,24 +4256,31 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (cons opcode offset) byte-compile-output) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) - +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; 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) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) ;;; call tree stuff @@ -4079,22 +4339,22 @@ invoked interactively." (if byte-compile-call-tree-sort (setq byte-compile-call-tree (sort byte-compile-call-tree - (cond ((eq byte-compile-call-tree-sort 'callers) - (function (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y)))))) - ((eq byte-compile-call-tree-sort 'calls) - (function (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y)))))) - ((eq byte-compile-call-tree-sort 'calls+callers) - (function (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y))))))) - ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) - (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) + (case byte-compile-call-tree-sort + (callers + (lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y))))) + (calls + (lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y))))) + (calls+callers + (lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) + (name + (lambda (x y) (string< (car x) (car y)))) + (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" + byte-compile-call-tree-sort)))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) @@ -4202,60 +4462,59 @@ Each file is processed even if an error occurred previously. For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". If NOFORCE is non-nil, don't recompile a file that seems to be already up-to-date." - ;; command-line-args-left is what is left of the command line (from startup.el) + ;; command-line-args-left is what is left of the command line, from + ;; startup.el. (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) - (let ((bytecomp-error nil)) + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) ;; Directory as argument. - (let ((bytecomp-files (directory-files (car command-line-args-left))) - bytecomp-source bytecomp-dest) - (dolist (bytecomp-file bytecomp-files) - (if (and (string-match emacs-lisp-file-regexp bytecomp-file) - (not (auto-save-file-name-p bytecomp-file)) - (setq bytecomp-source - (expand-file-name bytecomp-file + (let (source dest) + (dolist (file (directory-files (car command-line-args-left))) + (if (and (string-match emacs-lisp-file-regexp file) + (not (auto-save-file-name-p file)) + (setq source + (expand-file-name file (car command-line-args-left))) - (setq bytecomp-dest (byte-compile-dest-file - bytecomp-source)) - (file-exists-p bytecomp-dest) - (file-newer-than-file-p bytecomp-source bytecomp-dest)) - (if (null (batch-byte-compile-file bytecomp-source)) - (setq bytecomp-error t))))) + (setq dest (byte-compile-dest-file source)) + (file-exists-p dest) + (file-newer-than-file-p source dest)) + (if (null (batch-byte-compile-file source)) + (setq error t))))) ;; Specific file argument (if (or (not noforce) - (let* ((bytecomp-source (car command-line-args-left)) - (bytecomp-dest (byte-compile-dest-file bytecomp-source))) - (or (not (file-exists-p bytecomp-dest)) - (file-newer-than-file-p bytecomp-source bytecomp-dest)))) + (let* ((source (car command-line-args-left)) + (dest (byte-compile-dest-file source))) + (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 bytecomp-error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) - (kill-emacs (if bytecomp-error 1 0)))) + (kill-emacs (if error 1 0)))) -(defun batch-byte-compile-file (bytecomp-file) +(defun batch-byte-compile-file (file) (if debug-on-error - (byte-compile-file bytecomp-file) + (byte-compile-file file) (condition-case err - (byte-compile-file bytecomp-file) + (byte-compile-file file) (file-error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - bytecomp-file + file (get (car err) 'error-message) (prin1-to-string (cdr err))) - (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) - (if (file-exists-p bytecomp-destfile) - (delete-file bytecomp-destfile))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) nil) (error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - bytecomp-file + file (get (car err) 'error-message) (prin1-to-string (cdr err))) nil)))) @@ -4271,7 +4530,14 @@ Use with caution." (setq f (car f)) (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) (when (and (file-readable-p f) - (file-newer-than-file-p f emacs-file)) + (file-newer-than-file-p f emacs-file) + ;; Don't reload the source version of the files below + ;; because that causes subsequent byte-compilation to + ;; be a lot slower and need a higher max-lisp-eval-depth, + ;; so it can cause recompilation to fail. + (not (member (file-name-nondirectory f) + '("pcase.el" "bytecomp.el" "macroexp.el" + "cconv.el" "byte-opt.el")))) (message "Reloading stale %s" (file-name-nondirectory f)) (condition-case nil (load f 'noerror nil 'nosuffix) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el new file mode 100644 index 00000000000..5cc9ecb4cf7 --- /dev/null +++ b/lisp/emacs-lisp/cconv.el @@ -0,0 +1,713 @@ +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> +;; Maintainer: FSF +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This takes a piece of Elisp code, and eliminates all free variables from +;; lambda expressions. The user entry points are cconv-closure-convert and +;; cconv-closure-convert-toplevel(for toplevel forms). +;; All macros should be expanded beforehand. +;; +;; Here is a brief explanation how this code works. +;; Firstly, we analyse the tree by calling cconv-analyse-form. +;; This function finds all mutated variables, all functions that are suitable +;; for lambda lifting and all variables captured by closure. It passes the tree +;; once, returning a list of three lists. +;; +;; Then we calculate the intersection of first and third lists returned by +;; cconv-analyse form to find all mutated variables that are captured by +;; closure. + +;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the +;; tree recursivly, lifting lambdas where possible, building closures where it +;; is needed and eliminating mutable variables used in closure. +;; +;; We do following replacements : +;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) +;; if the function is suitable for lambda lifting (if all calls are known) +;; +;; (lambda (v0 ...) ... fv0 .. fv1 ...) => +;; (internal-make-closure (v0 ...) (fv1 ...) +;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) +;; +;; If the function has no free variables, we don't do anything. +;; +;; If a variable is mutated (updated by setq), and it is used in a closure +;; we wrap its definition with list: (list val) and we also replace +;; var => (car var) wherever this variable is used, and also +;; (setq var value) => (setcar var value) where it is updated. +;; +;; If defun argument is closure mutable, we letbind it and wrap it's +;; definition with list. +;; (defun foo (... mutable-arg ...) ...) => +;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) +;; +;;; Code: + +;; TODO: (not just for cconv but also for the lexbind changes in general) +;; - let (e)debug find the value of lexical variables from the stack. +;; - make eval-region do the eval-sexp-add-defvars danse. +;; - byte-optimize-form should be applied before cconv. +;; OTOH, the warnings emitted by cconv-analyze need to come before optimize +;; since afterwards they can because obnoxious (warnings about an "unused +;; variable" should not be emitted when the variable use has simply been +;; optimized away). +;; - turn defun and defmacro into macros (and remove special handling of +;; `declare' afterwards). +;; - let macros specify that some let-bindings come from the same source, +;; so the unused warning takes all uses into account. +;; - let interactive specs return a function to build the args (to stash into +;; command-history). +;; - canonize code in macro-expand so we don't have to handle (let (var) body) +;; and other oddities. +;; - new byte codes for unwind-protect, catch, and condition-case so that +;; closures aren't needed at all. +;; - inline source code of different binding mode by first compiling it. +;; - a reference to a var that is known statically to always hold a constant +;; should be turned into a byte-constant rather than a byte-stack-ref. +;; Hmm... right, that's called constant propagation and could be done here, +;; but when that constant is a function, we have to be careful to make sure +;; the bytecomp only compiles it once. +;; - Since we know here when a variable is not mutated, we could pass that +;; info to the byte-compiler, e.g. by using a new `immutable-let'. +;; - add tail-calls to bytecode.c and the byte compiler. +;; - call known non-escaping functions with `goto' rather than `call'. +;; - optimize mapcar to a while loop. + +;; (defmacro dlet (binders &rest body) +;; ;; Works in both lexical and non-lexical mode. +;; `(progn +;; ,@(mapcar (lambda (binder) +;; `(defvar ,(if (consp binder) (car binder) binder))) +;; binders) +;; (let ,binders ,@body))) + +;; (defmacro llet (binders &rest body) +;; ;; Only works in lexical-binding mode. +;; `(funcall +;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) +;; binders) +;; ,@body) +;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder))) +;; binders))) + +;; (defmacro letrec (binders &rest body) +;; ;; Only useful in lexical-binding mode. +;; ;; As a special-form, we could implement it more efficiently (and cleanly, +;; ;; making the vars actually unbound during evaluation of the binders). +;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) +;; binders) +;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder))) +;; binders)) +;; ,@body)) + +(eval-when-compile (require 'cl)) + +(defconst cconv-liftwhen 6 + "Try to do lambda lifting if the number of arguments + free variables +is less than this number.") +;; List of all the variables that are both captured by a closure +;; and mutated. Each entry in the list takes the form +;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the +;; variable (or is just (VAR) for variables not introduced by let). +(defvar cconv-captured+mutated) + +;; List of candidates for lambda lifting. +;; Each candidate has the form (BINDER . PARENTFORM). A candidate +;; is a variable that is only passed to `funcall' or `apply'. +(defvar cconv-lambda-candidates) + +;; Alist associating to each function body the list of its free variables. +(defvar cconv-freevars-alist) + +;;;###autoload +(defun cconv-closure-convert (form) + "Main entry point for closure conversion. +-- FORM is a piece of Elisp code after macroexpansion. +-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST + +Returns a form where all lambdas don't have any free variables." + ;; (message "Entering cconv-closure-convert...") + (let ((cconv-freevars-alist '()) + (cconv-lambda-candidates '()) + (cconv-captured+mutated '())) + ;; Analyse form - fill these variables with new information. + (cconv-analyse-form form '()) + (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) + (cconv-convert form nil nil))) ; Env initially empty. + +(defconst cconv--dummy-var (make-symbol "ignored")) + +(defun cconv--set-diff (s1 s2) + "Return elements of set S1 that are not in set S2." + (let ((res '())) + (dolist (x s1) + (unless (memq x s2) (push x res))) + (nreverse res))) + +(defun cconv--set-diff-map (s m) + "Return elements of set S that are not in Dom(M)." + (let ((res '())) + (dolist (x s) + (unless (assq x m) (push x res))) + (nreverse res))) + +(defun cconv--map-diff (m1 m2) + "Return the submap of map M1 that has Dom(M2) removed." + (let ((res '())) + (dolist (x m1) + (unless (assq (car x) m2) (push x res))) + (nreverse res))) + +(defun cconv--map-diff-elem (m x) + "Return the map M minus any mapping for X." + ;; Here we assume that X appears at most once in M. + (let* ((b (assq x m)) + (res (if b (remq b m) m))) + (assert (null (assq x res))) ;; Check the assumption was warranted. + res)) + +(defun cconv--map-diff-set (m s) + "Return the map M minus any mapping for elements of S." + ;; Here we assume that X appears at most once in M. + (let ((res '())) + (dolist (b m) + (unless (memq (car b) s) (push b res))) + (nreverse res))) + +(defun cconv--convert-function (args body env parentform) + (assert (equal body (caar cconv-freevars-alist))) + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (body-new '()) + (letbind '()) + (envector ()) + (i 0) + (new-env ())) + ;; Build the "formal and actual envs" for the closure-converted function. + (dolist (fv fvs) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + ;; If `fv' is a variable that's wrapped in a cons-cell, + ;; we want to put the cons-cell itself in the closure, + ;; rather than just a copy of its current content. + (`(car ,iexp . ,_) + (push iexp envector) + (push `(,fv . (car (internal-get-closed-var ,i))) new-env)) + (_ + (push exp envector) + (push `(,fv . (internal-get-closed-var ,i)) new-env)))) + (setq i (1+ i))) + (setq envector (nreverse envector)) + (setq new-env (nreverse new-env)) + + (dolist (arg args) + (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) + (if (assq arg new-env) (push `(,arg) new-env)) + (push `(,arg . (car ,arg)) new-env) + (push `(,arg (list ,arg)) letbind))) + + (setq body-new (mapcar (lambda (form) + (cconv-convert form new-env nil)) + body)) + + (when letbind + (let ((special-forms '())) + ;; Keep special forms at the beginning of the body. + (while (or (stringp (car body-new)) ;docstring. + (memq (car-safe (car body-new)) '(interactive declare))) + (push (pop body-new) special-forms)) + (setq body-new + `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) + + (cond + ((null envector) ;if no freevars - do nothing + `(function (lambda ,args . ,body-new))) + (t + `(internal-make-closure + ,args ,envector . ,body-new))))) + +(defun cconv-convert (form env extend) + ;; This function actually rewrites the tree. + "Return FORM with all its lambdas changed so they are closed. +ENV is a lexical environment mapping variables to the expression +used to get its value. This is used for variables that are copied into +closures, moved into cons cells, ... +ENV is a list where each entry takes the shape either: + (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP + is an expression that evaluates to this cons-cell. + (VAR . (internal-get-closed-var N)): VAR has been copied into the closure + environment's Nth slot. + (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes + additional arguments ARGs. +EXTEND is a list of variables which might need to be accessed even from places +where they are shadowed, because some part of ENV causes them to be used at +places where they originally did not directly appear." + (assert (not (delq nil (mapcar (lambda (mapping) + (if (eq (cadr mapping) 'apply-partially) + (cconv--set-diff (cdr (cddr mapping)) + extend))) + env)))) + + ;; What's the difference between fvrs and envs? + ;; Suppose that we have the code + ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) + ;; only the first occurrence of fvr should be replaced by + ;; (aref env ...). + ;; So initially envs and fvrs are the same thing, but when we descend to + ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? + ;; Because in envs the order of variables is important. We use this list + ;; to find the number of a specific variable in the environment vector, + ;; so we never touch it(unless we enter to the other closure). + ;;(if (listp form) (print (car form)) form) + (pcase form + (`(,(and letsym (or `let* `let)) ,binders . ,body) + + ; let and let* special forms + (let ((binders-new '()) + (new-env env) + (new-extend extend)) + + (dolist (binder binders) + (let* ((value nil) + (var (if (not (consp binder)) + (prog1 binder (setq binder (list binder))) + (setq value (cadr binder)) + (car binder))) + (new-val + (cond + ;; Check if var is a candidate for lambda lifting. + ((and (member (cons binder form) cconv-lambda-candidates) + (progn + (assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + ;; Peek at the freevars to decide whether to λ-lift. + (let* ((fvs (cdr (car cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs))) + ; lambda lifting condition + (and fvs (>= cconv-liftwhen (length funcvars)))))) + ; Lift. + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs)) + (funcbody (cddr fun)) + (funcbody-env ())) + (push `(,var . (apply-partially ,var . ,fvs)) new-env) + (dolist (fv fvs) + (pushnew fv new-extend) + (if (and (eq 'car (car-safe (cdr (assq fv env)))) + (not (memq fv funargs))) + (push `(,fv . (car ,fv)) funcbody-env))) + `(function (lambda ,funcvars . + ,(mapcar (lambda (form) + (cconv-convert + form funcbody-env nil)) + funcbody))))) + + ;; Check if it needs to be turned into a "ref-cell". + ((member (cons binder form) cconv-captured+mutated) + ;; Declared variable is mutated and captured. + (push `(,var . (car ,var)) new-env) + `(list ,(cconv-convert value env extend))) + + ;; Normal default case. + (t + (if (assq var new-env) (push `(,var) new-env)) + (cconv-convert value env extend))))) + + ;; The piece of code below letbinds free variables of a λ-lifted + ;; function if they are redefined in this let, example: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; Here we can not pass y as parameter because it is redefined. + ;; So we add a (closed-y y) declaration. We do that even if the + ;; function is not used inside this let(*). The reason why we + ;; ignore this case is that we can't "look forward" to see if the + ;; function is called there or not. To treat this case better we'd + ;; need to traverse the tree one more time to collect this data, and + ;; I think that it's not worth it. + (when (memq var new-extend) + (let ((closedsym + (make-symbol (concat "closed-" (symbol-name var))))) + (setq new-env + (mapcar (lambda (mapping) + (if (not (eq (cadr mapping) 'apply-partially)) + mapping + (assert (eq (car mapping) (nth 2 mapping))) + (list* (car mapping) + 'apply-partially + (car mapping) + (mapcar (lambda (arg) + (if (eq var arg) + closedsym arg)) + (nthcdr 3 mapping))))) + new-env)) + (setq new-extend (remq var new-extend)) + (push closedsym new-extend) + (push `(,closedsym ,var) binders-new))) + + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. + (push (list var new-val) binders-new) + + (when (eq letsym 'let*) + (setq env new-env) + (setq extend new-extend)) + )) ; end of dolist over binders + + `(,letsym ,(nreverse binders-new) + . ,(mapcar (lambda (form) + (cconv-convert + form new-env new-extend)) + body)))) + ;end of let let* forms + + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,args) + ;; FIXME: it's silly to create a closure just to call it. + ;; Running byte-optimize-form earlier will resolve this. + `(funcall + ,(cconv-convert `(function ,fun) env extend) + ,@(mapcar (lambda (form) + (cconv-convert form env extend)) + args))) + + (`(cond . ,cond-forms) ; cond special form + `(cond . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) + + (`(function (lambda ,args . ,body) . ,_) + (cconv--convert-function args body env form)) + + (`(internal-make-closure . ,_) + (byte-compile-report-error + "Internal error in compiler: cconv called twice?")) + + (`(quote . ,_) form) + (`(function . ,_) form) + + ;defconst, defvar + (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) + `(,sym ,definedsymbol + . ,(mapcar (lambda (form) (cconv-convert form env extend)) + forms))) + + ;defun, defmacro + (`(,(and sym (or `defun `defmacro)) + ,func ,args . ,body) + (assert (equal body (caar cconv-freevars-alist))) + (assert (null (cdar cconv-freevars-alist))) + + (let ((new (cconv--convert-function args body env form))) + (pcase new + (`(function (lambda ,newargs . ,new-body)) + (assert (equal args newargs)) + `(,sym ,func ,args . ,new-body)) + (t (byte-compile-report-error + (format "Internal error in cconv of (%s %s ...)" sym func)))))) + + ;condition-case + (`(condition-case ,var ,protected-form . ,handlers) + (let ((newform (cconv--convert-function + () (list protected-form) env form))) + `(condition-case :fun-body ,newform + ,@(mapcar (lambda (handler) + (list (car handler) + (cconv--convert-function + (list (or var cconv--dummy-var)) + (cdr handler) env form))) + handlers)))) + + (`(,(and head (or `catch `unwind-protect)) ,form . ,body) + `(,head ,(cconv-convert form env extend) + :fun-body ,(cconv--convert-function () body env form))) + + (`(track-mouse . ,body) + `(track-mouse + :fun-body ,(cconv--convert-function () body env form))) + + (`(setq . ,forms) ; setq special form + (let ((prognlist ())) + (while forms + (let* ((sym (pop forms)) + (sym-new (or (cdr (assq sym env)) sym)) + (value (cconv-convert (pop forms) env extend))) + (push (pcase sym-new + ((pred symbolp) `(setq ,sym-new ,value)) + (`(car ,iexp) `(setcar ,iexp ,value)) + ;; This "should never happen", but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (_ ;; (byte-compile-report-error + ;; (format "Internal error in cconv of (setq %s ..)" + ;; sym-new)) + value)) + prognlist))) + (if (cdr prognlist) + `(progn . ,(nreverse prognlist)) + (car prognlist)))) + + (`(,(and (or `funcall `apply) callsym) ,fun . ,args) + ;; These are not special forms but we treat them separately for the needs + ;; of lambda lifting. + (let ((mapping (cdr (assq fun env)))) + (pcase mapping + (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) + (assert (eq (cadr mapping) fun)) + `(,callsym ,fun + ,@(mapcar (lambda (fv) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + (`(car ,iexp . ,_) iexp) + (_ exp)))) + fvs) + ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + args))) + (_ `(,callsym ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + (cons fun args))))))) + + (`(interactive . ,forms) + `(interactive . ,(mapcar (lambda (form) + (cconv-convert form nil nil)) + forms))) + + (`(declare . ,_) form) ;The args don't contain code. + + (`(,func . ,forms) + ;; First element is function or whatever function-like forms are: or, and, + ;; if, progn, prog1, prog2, while, until + `(,func . ,(mapcar (lambda (form) + (cconv-convert form env extend)) + forms))) + + (_ (or (cdr (assq form env)) form)))) + +(unless (fboundp 'byte-compile-not-lexical-var-p) + ;; Only used to test the code in non-lexbind Emacs. + (defalias 'byte-compile-not-lexical-var-p 'boundp)) + +(defun cconv--analyse-use (vardata form varkind) + "Analyse the use of a variable. +VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). +VARKIND is the name of the kind of variable. +FORM is the parent form that binds this var." + ;; use = `(,binder ,read ,mutated ,captured ,called) + (pcase vardata + (`(,_ nil nil nil nil) nil) + (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) + ,_ ,_ ,_ ,_) + (byte-compile-log-warning + (format "%s `%S' not left unused" varkind var)))) + (pcase vardata + (`((,var . ,_) nil ,_ ,_ nil) + ;; FIXME: This gives warnings in the wrong order, with imprecise line + ;; numbers and without function name info. + (unless (or ;; Uninterned symbols typically come from macro-expansion, so + ;; it is often non-trivial for the programmer to avoid such + ;; unused vars. + (not (intern-soft var)) + (eq ?_ (aref (symbol-name var) 0))) + (byte-compile-log-warning (format "Unused lexical %s `%S'" + varkind var)))) + ;; If it's unused, there's no point converting it into a cons-cell, even if + ;; it's captured and mutated. + (`(,binder ,_ t t ,_) + (push (cons binder form) cconv-captured+mutated)) + (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) + (push (cons binder form) cconv-lambda-candidates)))) + +(defun cconv--analyse-function (args body env parentform) + (let* ((newvars nil) + (freevars (list body)) + ;; We analyze the body within a new environment where all uses are + ;; nil, so we can distinguish uses within that function from uses + ;; outside of it. + (envcopy + (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) + (newenv envcopy)) + ;; Push it before recursing, so cconv-freevars-alist contains entries in + ;; the order they'll be used by closure-convert-rec. + (push freevars cconv-freevars-alist) + (dolist (arg args) + (cond + ((byte-compile-not-lexical-var-p arg) + (byte-compile-log-warning + (format "Argument %S is not a lexical variable" arg))) + ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... + (t (let ((varstruct (list arg nil nil nil nil))) + (push (cons (list arg) (cdr varstruct)) newvars) + (push varstruct newenv))))) + (dolist (form body) ;Analyse body forms. + (cconv-analyse-form form newenv)) + ;; Summarize resulting data about arguments. + (dolist (vardata newvars) + (cconv--analyse-use vardata parentform "argument")) + ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; + ;; and compute free variables. + (while env + (assert (and envcopy (eq (caar env) (caar envcopy)))) + (let ((free nil) + (x (cdr (car env))) + (y (cdr (car envcopy)))) + (while x + (when (car y) (setcar x t) (setq free t)) + (setq x (cdr x) y (cdr y))) + (when free + (push (caar env) (cdr freevars)) + (setf (nth 3 (car env)) t)) + (setq env (cdr env) envcopy (cdr envcopy)))))) + +(defun cconv-analyse-form (form env) + "Find mutated variables and variables captured by closure. +Analyse lambdas if they are suitable for lambda lifting. +- FORM is a piece of Elisp code after macroexpansion. +- ENV is an alist mapping each enclosing lexical variable to its info. + I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). +This function does not return anything but instead fills the +`cconv-captured+mutated' and `cconv-lambda-candidates' variables +and updates the data stored in ENV." + (pcase form + ; let special form + (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) + + (let ((orig-env env) + (newvars nil) + (var nil) + (value nil)) + (dolist (binder binders) + (if (not (consp binder)) + (progn + (setq var binder) ; treat the form (let (x) ...) well + (setq binder (list binder)) + (setq value nil)) + (setq var (car binder)) + (setq value (cadr binder)) + + (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) + + (unless (byte-compile-not-lexical-var-p var) + (let ((varstruct (list var nil nil nil nil))) + (push (cons binder (cdr varstruct)) newvars) + (push varstruct env)))) + + (dolist (form body-forms) ; Analyse body forms. + (cconv-analyse-form form env)) + + (dolist (vardata newvars) + (cconv--analyse-use vardata form "variable")))) + + ; defun special form + (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) + (when env + (byte-compile-log-warning + (format "Function %S will ignore its context %S" + func (mapcar #'car env)) + t :warning)) + (cconv--analyse-function vrs body-forms nil form)) + + (`(function (lambda ,vrs . ,body-forms)) + (cconv--analyse-function vrs body-forms env form)) + + (`(setq . ,forms) + ;; If a local variable (member of env) is modified by setq then + ;; it is a mutated variable. + (while forms + (let ((v (assq (car forms) env))) ; v = non nil if visible + (when v (setf (nth 2 v) t))) + (cconv-analyse-form (cadr forms) env) + (setq forms (cddr forms)))) + + (`((lambda . ,_) . ,_) ; first element is lambda expression + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (cconv-analyse-form exp env))) + + (`(cond . ,cond-forms) ; cond special form + (dolist (forms cond-forms) + (dolist (form forms) (cconv-analyse-form form env)))) + + (`(quote . ,_) nil) ; quote form + (`(function . ,_) nil) ; same as quote + + (`(condition-case ,var ,protected-form . ,handlers) + ;; FIXME: The bytecode for condition-case forces us to wrap the + ;; form and handlers in closures (for handlers, it's understandable + ;; but not for the protected form). + (cconv--analyse-function () (list protected-form) env form) + (dolist (handler handlers) + (cconv--analyse-function (if var (list var)) (cdr handler) env form))) + + ;; FIXME: The bytecode for catch forces us to wrap the body. + (`(,(or `catch `unwind-protect) ,form . ,body) + (cconv-analyse-form form env) + (cconv--analyse-function () body env form)) + + ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. + ;; `track-mouse' really should be made into a macro. + (`(track-mouse . ,body) + (cconv--analyse-function () body env form)) + + (`(,(or `defconst `defvar) ,var ,value . ,_) + (push var byte-compile-bound-variables) + (cconv-analyse-form value env)) + + (`(,(or `funcall `apply) ,fun . ,args) + ;; Here we ignore fun because funcall and apply are the only two + ;; functions where we can pass a candidate for lambda lifting as + ;; argument. So, if we see fun elsewhere, we'll delete it from + ;; lambda candidate list. + (let ((fdata (and (symbolp fun) (assq fun env)))) + (if fdata + (setf (nth 4 fdata) t) + (cconv-analyse-form fun env))) + (dolist (form args) (cconv-analyse-form form env))) + + (`(interactive . ,forms) + ;; These appear within the function body but they don't have access + ;; to the function's arguments. + ;; We could extend this to allow interactive specs to refer to + ;; variables in the function's enclosing environment, but it doesn't + ;; seem worth the trouble. + (dolist (form forms) (cconv-analyse-form form nil))) + + (`(declare . ,_) nil) ;The args don't contain code. + + (`(,_ . ,body-forms) ; First element is a function or whatever. + (dolist (form body-forms) (cconv-analyse-form form env))) + + ((pred symbolp) + (let ((dv (assq form env))) ; dv = declared and visible + (when dv + (setf (nth 1 dv) t)))))) + +(provide 'cconv) +;;; cconv.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 885424ec726..7468a0237cf 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -766,20 +766,15 @@ This also does some trivial optimizations to make the form prettier." (eq (car-safe (car body)) 'interactive)) (push (list 'quote (pop body)) decls)) (put (car (last cl-closure-vars)) 'used t) - (append - (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) - (sublis sub (nreverse decls)) - (list - (list* 'list '(quote apply) - (list 'function - (list* 'lambda - (append new (cadadr form)) - (sublis sub body))) - (nconc (mapcar (function - (lambda (x) - (list 'list '(quote quote) x))) - cl-closure-vars) - '((quote --cl-rest--))))))) + `(list 'lambda '(&rest --cl-rest--) + ,@(sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadadr form)) + ,@(sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) (list (car form) (list* 'lambda (cadadr form) body)))) (let ((found (assq (cadr form) env))) (if (and found (ignore-errors diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 08001171ed1..4c824d4a6d4 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -277,12 +277,12 @@ Not documented ;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct ;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf ;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method -;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let* -;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq -;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from -;;;;;; return block etypecase typecase ecase case load-time-value -;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp -;;;;;; gensym) "cl-macs" "cl-macs.el" "b3031039e82679e5b013ce1cbf174ee8") +;;;;;; declare the locally multiple-value-setq multiple-value-bind +;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels +;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist +;;;;;; do* do loop return-from return block etypecase typecase ecase +;;;;;; case load-time-value eval-when destructuring-bind function* +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions. \(fn FUNC)" nil (quote macro)) (autoload 'destructuring-bind "cl-macs" "\ -Not documented + \(fn ARGS EXPR &rest BODY)" nil (quote macro)) @@ -445,7 +445,7 @@ from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) (autoload 'do-all-symbols "cl-macs" "\ -Not documented + \(fn SPEC &rest BODY)" nil (quote macro)) @@ -500,16 +500,16 @@ Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. -\(fn VARLIST BODY)" nil (quote macro)) +\(fn BINDINGS BODY)" nil (quote macro)) (autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in -successive bindings within VARLIST, will create lexical closures +successive bindings within BINDINGS, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. -\(fn VARLIST BODY)" nil (quote macro)) +\(fn BINDINGS BODY)" nil (quote macro)) (autoload 'multiple-value-bind "cl-macs" "\ Collect multiple return values. @@ -531,12 +531,17 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" nil (quote macro)) (autoload 'locally "cl-macs" "\ -Not documented + \(fn &rest BODY)" nil (quote macro)) +(autoload 'the "cl-macs" "\ + + +\(fn TYPE FORM)" nil (quote macro)) + (autoload 'declare "cl-macs" "\ -Not documented + \(fn &rest SPECS)" nil (quote macro)) @@ -596,7 +601,7 @@ before assigning any PLACEs to the corresponding values. \(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) (autoload 'cl-do-pop "cl-macs" "\ -Not documented + \(fn PLACE)" nil nil) @@ -684,7 +689,7 @@ value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" nil (quote macro)) (autoload 'cl-struct-setf-expander "cl-macs" "\ -Not documented + \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) @@ -730,7 +735,7 @@ and then returning foo. \(fn FUNC ARGS &rest BODY)" nil (quote macro)) (autoload 'compiler-macroexpand "cl-macs" "\ -Not documented + \(fn FORM)" nil nil) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c57d37703b0..9ce3dd6a7fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." (symbol-function 'byte-compile-file-form))) (list 'byte-compile-file-form (list 'quote set)) '(byte-compile-file-form form))) - (print set (symbol-value 'bytecomp-outbuffer))) + (print set (symbol-value 'byte-compile--outbuffer))) (list 'symbol-value (list 'quote temp))) (list 'quote (eval form)))) @@ -598,27 +598,6 @@ called from BODY." (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) body)))) -(defvar cl-active-block-names nil) - -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) - -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) - ;;;###autoload (defmacro return (&optional result) "Return from the block named nil. @@ -1427,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. -\n(fn VARLIST BODY)" +\n(fn BINDINGS BODY)" (let* ((cl-closure-vars cl-closure-vars) (vars (mapcar (function (lambda (x) @@ -1470,10 +1449,10 @@ lexical closures as in Common Lisp. (defmacro lexical-let* (bindings &rest body) "Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in -successive bindings within VARLIST, will create lexical closures +successive bindings within BINDINGS, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. -\n(fn VARLIST BODY)" +\n(fn BINDINGS BODY)" (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -2422,11 +2401,13 @@ value, that slot cannot be set via `setf'. (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func - (push (list 'push - (list 'function - (list 'lambda '(cl-x cl-s cl-n) - (list 'and pred-form print-func))) - 'custom-print-functions) forms)) + (push `(push + ;; The auto-generated function does not pay attention to + ;; the depth argument cl-n. + (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) + (and ,pred-form ,print-func)) + custom-print-functions) + forms)) (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) (push (list* 'eval-when '(compile load eval) (list 'put (list 'quote name) '(quote cl-struct-slots) @@ -2580,7 +2561,7 @@ and then returning foo." (cl-transform-function-property func 'cl-compiler-macro (cons (if (memq '&whole args) (delq '&whole args) - (cons '--cl-whole-arg-- args)) body)) + (cons '_cl-whole-arg args)) body)) (list 'or (list 'get (list 'quote func) '(quote byte-compile)) (list 'progn (list 'put (list 'quote func) '(quote byte-compile) @@ -2618,6 +2599,27 @@ and then returning foo." (byte-compile-normal-call form) (byte-compile-form form))) +;; Optimize away unused block-wrappers. + +(defvar cl-active-block-names nil) + +(define-compiler-macro cl-block-wrapper (cl-form) + (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) + (cl-active-block-names (cons cl-entry cl-active-block-names)) + (cl-body (macroexpand-all ;Performs compiler-macro expansions. + (cons 'progn (cddr cl-form)) + macroexpand-all-environment))) + ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able + ;; to indicate that this return value is already fully expanded. + (if (cdr cl-entry) + `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) + cl-body))) + +(define-compiler-macro cl-block-throw (cl-tag cl-value) + (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) + (if cl-found (setcdr cl-found t))) + `(throw ,cl-tag ,cl-value)) + ;;;###autoload (defmacro defsubst* (name args &rest body) "Define NAME as a function. diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 1d2b82f82eb..526475eb1bd 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -161,7 +161,14 @@ an element already on the list. (if (symbolp place) (if (null keys) `(let ((x ,x)) - (if (memql x ,place) ,place (setq ,place (cons x ,place)))) + (if (memql x ,place) + ;; This symbol may later on expand to actual code which then + ;; trigger warnings like "value unused" since pushnew's return + ;; value is rarely used. It should not matter that other + ;; warnings may be silenced, since `place' is used earlier and + ;; should have triggered them already. + (with-no-warnings ,place) + (setq ,place (cons x ,place)))) (list 'setq place (list* 'adjoin x place keys))) (list* 'callf2 'adjoin x place keys))) @@ -271,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. (defvar cl-compiling-file nil) (defun cl-compiling-file () (or cl-compiling-file - (and (boundp 'bytecomp-outbuffer) - (bufferp (symbol-value 'bytecomp-outbuffer)) - (equal (buffer-name (symbol-value 'bytecomp-outbuffer)) + (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) " *Compiler Output*")))) (defvar cl-proclaims-deferred nil) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9f4cca91676..4fd10185c17 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -78,13 +78,14 @@ redefine OBJECT if it is a symbol." obj (symbol-function obj))) (if (subrp obj) (error "Can't disassemble #<subr %s>" name)) - (if (and (listp obj) (eq (car obj) 'autoload)) - (progn - (load (nth 1 obj)) - (setq obj (symbol-function name)))) + (when (and (listp obj) (eq (car obj) 'autoload)) + (load (nth 1 obj)) + (setq obj (symbol-function name))) (if (eq (car-safe obj) 'macro) ;handle macros (setq macro t obj (cdr obj))) + (when (and (listp obj) (eq (car obj) 'closure)) + (error "Don't know how to compile an interpreted closure")) (if (and (listp obj) (eq (car obj) 'byte-code)) (setq obj (list 'lambda nil obj))) (if (and (listp obj) (not (eq (car obj) 'lambda))) @@ -215,7 +216,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (cond ((memq op byte-goto-ops) (insert (int-to-string (nth 1 arg)))) ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) + byte-listN byte-concatN byte-insertN + byte-stack-ref byte-stack-set byte-stack-set2 + byte-discardN byte-discardN-preserve-tos)) (insert (int-to-string arg))) ((memq op '(byte-varref byte-varset byte-varbind)) (prin1 (car arg) (current-buffer))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 70a7983dbea..f84de0308bf 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -519,7 +519,8 @@ the minibuffer." ((and (eq (car form) 'defcustom) (default-boundp (nth 1 form))) ;; Force variable to be bound. - (set-default (nth 1 form) (eval (nth 2 form)))) + ;; FIXME: Shouldn't this use the :setter or :initializer? + (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) ((eq (car form) 'defface) ;; Reset the face. (setq face-new-frame-defaults @@ -532,7 +533,7 @@ the minibuffer." (put ',(nth 1 form) 'customized-face ,(nth 2 form))) (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval form)) + (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) (if (not edebugging) (princ edebug-result) edebug-result))) @@ -565,7 +566,8 @@ already is one.)" ;; but this causes problems while edebugging edebug. (let ((edebug-all-forms t) (edebug-all-defs t)) - (edebug-read-top-level-form)))) + (eval-sexp-add-defvars + (edebug-read-top-level-form))))) (defun edebug-read-top-level-form () @@ -2462,6 +2464,7 @@ MSG is printed after `::::} '." (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result + ;; FIXME: lexbind. (eval edebug-global-break-condition)) (error nil)))) (edebug-break)) @@ -2473,6 +2476,7 @@ MSG is printed after `::::} '." (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result + ;; FIXME: lexbind. (eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? @@ -3633,9 +3637,10 @@ Return the result of the last expression." (defun edebug-eval (edebug-expr) ;; Are there cl lexical variables active? - (if (bound-and-true-p cl-debug-env) - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) + (eval (if (bound-and-true-p cl-debug-env) + (cl-macroexpand-all edebug-expr cl-debug-env) + edebug-expr) + lexical-binding)) (defun edebug-safe-eval (edebug-expr) ;; Evaluate EXPR safely. @@ -4237,8 +4242,8 @@ It is removed when you hit any char." ;;; Menus (defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) + (set variable (not (symbol-value variable))) + (message "%s: %s" variable (symbol-value variable))) ;; We have to require easymenu (even for Emacs 18) just so ;; the easy-menu-define macro call is compiled correctly. diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el deleted file mode 100644 index ed6fb6f1c41..00000000000 --- a/lisp/emacs-lisp/eieio-comp.el +++ /dev/null @@ -1,142 +0,0 @@ -;;; eieio-comp.el -- eieio routines to help with byte compilation - -;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011 -;; Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.2 -;; Keywords: lisp, tools -;; Package: eieio - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Byte compiler functions for defmethod. This will affect the new GNU -;; byte compiler for Emacs 19 and better. This function will be called by -;; the byte compiler whenever a `defmethod' is encountered in a file. -;; It will output a function call to `eieio-defmethod' with the byte -;; compiled function as a parameter. - -;;; Code: - -(declare-function eieio-defgeneric-form "eieio" (method doc-string)) - -;; Some compatibility stuff -(eval-and-compile - (if (not (fboundp 'byte-compile-compiled-obj-to-list)) - (defun byte-compile-compiled-obj-to-list (moose) nil)) - - (if (not (boundp 'byte-compile-outbuffer)) - (defvar byte-compile-outbuffer nil)) - ) - -;; This teaches the byte compiler how to do this sort of thing. -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) - -(defun byte-compile-file-form-defmethod (form) - "Mumble about the method we are compiling. -This function is mostly ripped from `byte-compile-file-form-defun', -but it's been modified to handle the special syntax of the `defmethod' -command. There should probably be one for `defgeneric' as well, but -that is called but rarely. Argument FORM is the body of the method." - (setq form (cdr form)) - (let* ((meth (car form)) - (key (progn (setq form (cdr form)) - (cond ((or (eq ':BEFORE (car form)) - (eq ':before (car form))) - (setq form (cdr form)) - ":before ") - ((or (eq ':AFTER (car form)) - (eq ':after (car form))) - (setq form (cdr form)) - ":after ") - ((or (eq ':PRIMARY (car form)) - (eq ':primary (car form))) - (setq form (cdr form)) - ":primary ") - ((or (eq ':STATIC (car form)) - (eq ':static (car form))) - (setq form (cdr form)) - ":static ") - (t "")))) - (params (car form)) - (lamparams (byte-compile-defmethod-param-convert params)) - (arg1 (car params)) - (class (if (listp arg1) (nth 1 arg1) nil)) - (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) - byte-compile-outbuffer - (cond ((boundp 'bytecomp-outbuffer) - bytecomp-outbuffer) ; Emacs >= 23.2 - ((boundp 'outbuffer) outbuffer) - (t (error "Unable to set outbuffer")))))) - (let ((name (format "%s::%s" (or class "#<generic>") meth))) - (if byte-compile-verbose - ;; #### filename used free - (message "Compiling %s... (%s)" - (cond ((boundp 'bytecomp-filename) bytecomp-filename) - ((boundp 'filename) filename) - (t "")) - name)) - (setq byte-compile-current-form name) ; for warnings - ) - ;; Flush any pending output - (byte-compile-flush-pending) - ;; Byte compile the body. For the byte compiled forms, add the - ;; rest arguments, which will get ignored by the engine which will - ;; add them later (I hope) - (let* ((new-one (byte-compile-lambda - (append (list 'lambda lamparams) - (cdr form)))) - (code (byte-compile-byte-code-maker new-one))) - (princ "\n(eieio-defmethod '" my-outbuffer) - (princ meth my-outbuffer) - (princ " '(" my-outbuffer) - (princ key my-outbuffer) - (prin1 params my-outbuffer) - (princ " " my-outbuffer) - (prin1 code my-outbuffer) - (princ "))" my-outbuffer) - ) - ;; Now add this function to the list of known functions. - ;; Don't bother with a doc string. Not relevant here. - (add-to-list 'byte-compile-function-environment - (cons meth - (eieio-defgeneric-form meth ""))) - - ;; Remove it from the undefined list if it is there. - (let ((elt (assq meth byte-compile-unresolved-functions))) - (if elt (setq byte-compile-unresolved-functions - (delq elt byte-compile-unresolved-functions)))) - - ;; nil prevents cruft from appearing in the output buffer. - nil)) - -(defun byte-compile-defmethod-param-convert (paramlist) - "Convert method params into the params used by the `defmethod' thingy. -Argument PARAMLIST is the parameter list to convert." - (let ((argfix nil)) - (while paramlist - (setq argfix (cons (if (listp (car paramlist)) - (car (car paramlist)) - (car paramlist)) - argfix)) - (setq paramlist (cdr paramlist))) - (nreverse argfix))) - -(provide 'eieio-comp) - -;;; eieio-comp.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 2fe33dfce2e..7a119e6bbc0 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -45,8 +45,7 @@ ;;; Code: (eval-when-compile - (require 'cl) - (require 'eieio-comp)) + (require 'cl)) (defvar eieio-version "1.3" "Current version of EIEIO.") @@ -97,6 +96,7 @@ default setting for optimization purposes.") "Non-nil means to optimize the method dispatch on primary methods.") ;; State Variables +;; FIXME: These two constants below should have an `eieio-' prefix added!! (defvar this nil "Inside a method, this variable is the object in question. DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. @@ -123,6 +123,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!") ;; while it is being built itself. (defvar eieio-default-superclass nil) +;; FIXME: The constants below should have an `eieio-' prefix added!! (defconst class-symbol 1 "Class's symbol (self-referencing.).") (defconst class-parent 2 "Class parent slot.") (defconst class-children 3 "Class children class slot.") @@ -181,10 +182,6 @@ Stored outright without modifications or stripping.") (t key) ;; already generic.. maybe. )) -;; How to specialty compile stuff. -(autoload 'byte-compile-file-form-defmethod "eieio-comp" - "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -1192,10 +1189,8 @@ IMPL is the symbol holding the method implementation." ;; is faster to execute this for not byte-compiled. ie, install this, ;; then measure calls going through here. I wonder why. (require 'bytecomp) - (let ((byte-compile-free-references nil) - (byte-compile-warnings nil) - ) - (byte-compile-lambda + (let ((byte-compile-warnings nil)) + (byte-compile `(lambda (&rest local-args) ,doc-string ;; This is a cool cheat. Usually we need to look up in the @@ -1205,7 +1200,8 @@ IMPL is the symbol holding the method implementation." ;; of that one implementation, then clearly, there is no method def. (if (not (eieio-object-p (car local-args))) ;; Not an object. Just signal. - (signal 'no-method-definition (list ,(list 'quote method) local-args)) + (signal 'no-method-definition + (list ,(list 'quote method) local-args)) ;; We do have an object. Make sure it is the right type. (if ,(if (eq class eieio-default-superclass) @@ -1228,9 +1224,7 @@ IMPL is the symbol holding the method implementation." ) (apply ,(list 'quote impl) local-args) ;(,impl local-args) - )))) - ) - )) + ))))))) (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) "Setup METHOD to call the generic form." @@ -1296,9 +1290,35 @@ Summary: ((typearg class-name) arg2 &optional opt &rest rest) \"doc-string\" body)" - `(eieio-defmethod (quote ,method) (quote ,args))) - -(defun eieio-defmethod (method args) + (let* ((key (cond ((or (eq ':BEFORE (car args)) + (eq ':before (car args))) + (setq args (cdr args)) + :before) + ((or (eq ':AFTER (car args)) + (eq ':after (car args))) + (setq args (cdr args)) + :after) + ((or (eq ':PRIMARY (car args)) + (eq ':primary (car args))) + (setq args (cdr args)) + :primary) + ((or (eq ':STATIC (car args)) + (eq ':static (car args))) + (setq args (cdr args)) + :static) + (t nil))) + (params (car args)) + (lamparams + (mapcar (lambda (param) (if (listp param) (car param) param)) + params)) + (arg1 (car params)) + (class (if (listp arg1) (nth 1 arg1) nil))) + `(eieio-defmethod ',method + '(,@(if key (list key)) + ,params) + (lambda ,lamparams ,@(cdr args))))) + +(defun eieio-defmethod (method args &optional code) "Work part of the `defmethod' macro defining METHOD with ARGS." (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) ;; find optional keys @@ -1352,10 +1372,7 @@ Summary: ;; generics are higher (setq key (eieio-specialized-key-to-generic-key key))) ;; Put this lambda into the symbol so we can find it - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) + (eieiomt-add method code key argclass) ) (when eieio-optimize-primary-methods-flag diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index ceb1eb3bafb..7e40fdad352 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -28,7 +28,13 @@ ;; Provide an easy hook to tell if we are running with floats or not. ;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") -(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") +(progn + ;; Simulate a defconst that doesn't declare the variable dynamically bound. + (setq-default pi float-pi) + (put 'pi 'variable-documentation + "Obsolete since Emacs-23.3. Use `float-pi' instead.") + (put 'pi 'risky-local-variable t) + (push 'pi current-load-list)) (defconst float-e (exp 1) "The value of e (2.7182818...).") diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 15690023700..39bdb505039 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -699,7 +699,9 @@ If CHAR is not a character, return nil." "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) - (eval-last-sexp-print-value (eval (preceding-sexp))))) + ;; Setup the lexical environment if lexical-binding is enabled. + (eval-last-sexp-print-value + (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding)))) (defun eval-last-sexp-print-value (value) @@ -727,6 +729,23 @@ With argument, print output into current buffer." (defvar eval-last-sexp-fake-value (make-symbol "t")) +(defun eval-sexp-add-defvars (exp &optional pos) + "Prepend EXP with all the `defvar's that precede it in the buffer. +POS specifies the starting position where EXP was found and defaults to point." + (if (not lexical-binding) + exp + (save-excursion + (unless pos (setq pos (point))) + (let ((vars ())) + (goto-char (point-min)) + (while (re-search-forward + "^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" + pos t) + (let ((var (intern (match-string 1)))) + (unless (special-variable-p var) + (push var vars)))) + `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) + (defun eval-last-sexp (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. Interactively, with prefix argument, print output into current buffer. @@ -763,16 +782,18 @@ Reinitialize the face according to the `defface' specification." ;; `defcustom' is now macroexpanded to ;; `custom-declare-variable' with a quoted value arg. ((and (eq (car form) 'custom-declare-variable) - (default-boundp (eval (nth 1 form)))) + (default-boundp (eval (nth 1 form) lexical-binding))) ;; Force variable to be bound. - (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) + (set-default (eval (nth 1 form) lexical-binding) + (eval (nth 1 (nth 2 form)) lexical-binding)) form) ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) ;; Reset the face. (setq face-new-frame-defaults - (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) - (put (eval (nth 1 form)) 'face-defface-spec nil) + (assq-delete-all (eval (nth 1 form) lexical-binding) + face-new-frame-defaults)) + (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil) ;; Setting `customized-face' to the new spec after calling ;; the form, but preserving the old saved spec in `saved-face', ;; imitates the situation when the new face spec is set @@ -783,10 +804,11 @@ Reinitialize the face according to the `defface' specification." ;; `defface' change the spec, regardless of a saved spec. (prog1 `(prog1 ,form (put ,(nth 1 form) 'saved-face - ',(get (eval (nth 1 form)) 'saved-face)) + ',(get (eval (nth 1 form) lexical-binding) + 'saved-face)) (put ,(nth 1 form) 'customized-face ,(nth 2 form))) - (put (eval (nth 1 form)) 'saved-face nil))) + (put (eval (nth 1 form) lexical-binding) 'saved-face nil))) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) @@ -1205,7 +1227,6 @@ This function also returns nil meaning don't specify the indentation." (put 'prog1 'lisp-indent-function 1) (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) -(put 'save-window-excursion 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index af8047256e2..f0a075ace37 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,4 +1,4 @@ -;;; macroexp.el --- Additional macro-expansion support +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; ;; Copyright (C) 2004-2011 Free Software Foundation, Inc. ;; @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -106,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand (macroexpand-all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexpand form macroexpand-all-environment)) + (let ((new-form (macroexpand form macroexpand-all-environment))) + (when (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info) + (fboundp 'byte-compile-warn-obsolete)) + (byte-compile-warn-obsolete (car form))) + (setq form new-form)) (pcase form (`(cond . ,clauses) (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) @@ -122,7 +131,16 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(defmacro ,name . ,args-and-body) (push (cons name (cons 'lambda args-and-body)) macroexpand-all-environment) - (macroexpand-all-forms form 3)) + (let ((n 3)) + ;; Don't macroexpand `declare' since it should really be "expanded" + ;; away when `defmacro' is expanded, but currently defmacro is not + ;; itself a macro. So both `defmacro' and `declare' need to be + ;; handled directly in bytecomp.el. + ;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote). + (while (or (stringp (nth n form)) + (eq (car-safe (nth n form)) 'declare)) + (setq n (1+ n))) + (macroexpand-all-forms form n))) (`(defun . ,_) (macroexpand-all-forms form 3)) (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) (`(function ,(and f `(lambda . ,_))) @@ -151,19 +169,34 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; here, so that any code that cares about the difference will ;; see the same transformation. ;; First arg is a function: - (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) + (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) + ',(and f `(lambda . ,_)) . ,args) ;; We don't use `maybe-cons' since there's clearly a change. (cons fun (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args)))) ;; Second arg is a function: - (`(,(and fun (or `sort)) ,arg1 ',f . ,args) + (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) ;; We don't use `maybe-cons' since there's clearly a change. (cons fun (cons (macroexpand-all-1 arg1) (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + ;; FIXME: Don't depend on CL. + (`(,(pred (lambda (fun) + (and (symbolp fun) + (eq (get fun 'byte-compile) + 'cl-byte-compile-compiler-macro) + (functionp 'compiler-macroexpand)))) + . ,_) + (let ((newform (with-no-warnings (compiler-macroexpand form)))) + (if (eq form newform) + (macroexpand-all-forms form 1) + (macroexpand-all-1 newform)))) (`(,_ . ,_) ;; For every other list, we just expand each argument (for ;; setq/setq-default this works alright because the variable names diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 916dcd4785c..e6c4ccbbc50 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,4 +1,4 @@ -;;; pcase.el --- ML-style pattern-matching macro for Elisp +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -27,16 +27,21 @@ ;; Todo: +;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't +;; use x, because x is bound separately for the equality constraint +;; (as well as any pred/guard) and for the body, so uses at one place don't +;; count for the other. ;; - provide ways to extend the set of primitives, with some kind of ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). ;; But better would be if we could define new ways to match by having the ;; extension provide its own `pcase--split-<foo>' thingy. +;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to other cases. +;; - provide a way to fallthrough to subsequent cases. ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leafs that need to be turned into function: +;; to reduce the number of leaves that need to be turned into function: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better so it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -45,14 +50,12 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we ;; memoize previous macro expansions to try and avoid recomputing them ;; over and over again. -(defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) +(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) (defconst pcase--dontcare-upats '(t _ dontcare)) @@ -69,6 +72,7 @@ UPatterns can take the following forms: `QPAT matches if the QPattern QPAT matches. (pred PRED) matches if PRED applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. + (let UPAT EXP) matches if EXP matches UPAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. @@ -88,10 +92,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. - (or (gethash (cons exp cases) pcase-memoize) - (puthash (cons exp cases) - (pcase--expand exp cases) - pcase-memoize))) + ;; We want to use a weak hash table as a cache, but the key will unavoidably + ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time + ;; we're called so it'll be immediately GC'd. So we use (car cases) as key + ;; which does come straight from the source code and should hence not be GC'd + ;; so easily. + (let ((data (gethash (car cases) pcase--memoize))) + ;; data = (EXP CASES . EXPANSION) + (if (and (equal exp (car data)) (equal cases (cadr data))) + ;; We have the right expansion. + (cddr data) + (when data + (message "pcase-memoize: equal first branch, yet different")) + (let ((expansion (pcase--expand exp cases))) + (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize) + expansion)))) ;;;###autoload (defmacro pcase-let* (bindings &rest body) @@ -145,6 +160,8 @@ of the form (UPAT EXP)." (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) (defun pcase--expand (exp cases) + ;; (message "pid=%S (pcase--expand %S ...hash=%S)" + ;; (emacs-pid) exp (sxhash cases)) (let* ((defs (if (symbolp exp) '() (let ((sym (make-symbol "x"))) (prog1 `((,sym ,exp)) (setq exp sym))))) @@ -165,7 +182,9 @@ of the form (UPAT EXP)." ;; to a separate function if that number is too high. ;; ;; We've already used this branch. So it is shared. - (destructuring-bind (code prevvars res) prev + (let* ((code (car prev)) (cdrprev (cdr prev)) + (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) + (res (car cddrprev))) (unless (symbolp res) ;; This is the first repeat, so we have to move ;; the branch to a separate function. @@ -269,7 +288,10 @@ MATCH is the pattern that needs to be matched, of the form: (and MATCH ...) (or MATCH ...)" (when (setq branches (delq nil branches)) - (destructuring-bind (match code &rest vars) (car branches) + (let* ((carbranch (car branches)) + (match (car carbranch)) (cdarbranch (cdr carbranch)) + (code (car cdarbranch)) + (vars (cdr cdarbranch))) (pcase--u1 (list match) code vars (cdr branches))))) (defun pcase--and (match matches) @@ -281,19 +303,25 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . consp) (symbolp . arrayp) (symbolp . stringp) + (symbolp . byte-code-function-p) (integerp . consp) (integerp . arrayp) (integerp . stringp) + (integerp . byte-code-function-p) (numberp . consp) (numberp . arrayp) (numberp . stringp) + (numberp . byte-code-function-p) (consp . arrayp) (consp . stringp) - (arrayp . stringp))) + (consp . byte-code-function-p) + (arrayp . stringp) + (arrayp . byte-code-function-p) + (stringp . byte-code-function-p))) (defun pcase--split-match (sym splitter match) - (case (car match) - ((match) + (cond + ((eq (car match) 'match) (if (not (eq sym (cadr match))) (cons match match) (let ((pat (cddr match))) @@ -307,7 +335,7 @@ MATCH is the pattern that needs to be matched, of the form: (cdr pat))))) (t (let ((res (funcall splitter (cddr match)))) (cons (or (car res) match) (or (cdr res) match)))))))) - ((or and) + ((memq (car match) '(or and)) (let ((then-alts '()) (else-alts '()) (neutral-elem (if (eq 'or (car match)) @@ -474,53 +502,60 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) code vars (if (null others) rest - (cons (list* + (cons (cons (pcase--and (if (cdr others) (cons 'or (nreverse others)) (car others)) (cdr matches)) - code vars) + (cons code vars)) rest)))) (t (pcase--u1 (cons (pop alts) (cdr matches)) code vars (if (null alts) (progn (error "Please avoid it") rest) - (cons (list* + (cons (cons (pcase--and (if (cdr alts) (cons 'or alts) (car alts)) (cdr matches)) - code vars) + (cons code vars)) rest))))))) ((eq 'match (caar matches)) - (destructuring-bind (op sym &rest upat) (pop matches) + (let* ((popmatches (pop matches)) + (_op (car popmatches)) (cdrpopmatches (cdr popmatches)) + (sym (car cdrpopmatches)) + (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) ((eq upat 'dontcare) :pcase--dontcare) - ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (put sym 'pcase-used t)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-pred upat) rest) + (let* ((splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-pred upat) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. (vs (pcase--fgrep (mapcar #'car vars) exp)) - (call (cond - ((eq 'guard (car upat)) exp) - ((functionp exp) `(,exp ,sym)) - (t `(,@exp ,sym))))) + (env (mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs)) + (call (if (eq 'guard (car upat)) + exp + (when (memq sym vs) + ;; `sym' is shadowed by `env'. + (let ((newsym (make-symbol "x"))) + (push (list newsym sym) env) + (setq sym newsym))) + (if (functionp exp) `(,exp ,sym) + `(,@exp ,sym))))) (if (null vs) call ;; Let's not replace `vars' in `exp' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `exp'. - `(let ,(mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs) - ;; FIXME: `vars' can capture `sym'. E.g. - ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) - ,call)))) + `(let* ,env ,call)))) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) ((symbolp upat) @@ -531,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) matches) code vars rest))) + ((eq (car-safe upat) 'let) + ;; A upat of the form (let VAR EXP). + ;; (pcase--u1 matches code + ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) + (let* ((exp + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env `(let* ,env ,exp) exp))))) + (sym (if (symbolp exp) exp (make-symbol "x"))) + (body + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) + (if (eq sym exp) + body + `(let* ((,sym ,exp)) ,body)))) ((eq (car-safe upat) '\`) (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) @@ -546,13 +600,15 @@ Otherwise, it defers to REST which is a list of branches of the form (setq all nil)))) (if all ;; Use memq for (or `a `b `c `d) rather than a big tree. - (let ((elems (mapcar 'cadr (cdr upat)))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-member elems) rest) - (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest)))) + (let* ((elems (mapcar 'cadr (cdr upat))) + (splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-member elems) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest))) (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars (append (mapcar (lambda (upat) `((and (match ,sym . ,upat) ,@matches) @@ -575,15 +631,14 @@ Otherwise, it defers to REST which is a list of branches of the form ;; `(PAT3 . PAT4)) which the programmer can easily rewrite ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). (pcase--u1 `((match ,sym . ,(cadr upat))) - (lexical-let ((rest rest)) - ;; FIXME: This codegen is not careful to share its - ;; code if used several times: code blow up is likely. - (lambda (vars) - ;; `vars' will likely contain bindings which are - ;; not always available in other paths to - ;; `rest', so there' no point trying to pass - ;; them down. - (pcase--u rest))) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (_vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) (t (error "Unknown upattern `%s'" upat))))) @@ -600,29 +655,33 @@ Otherwise, it defers to REST which is a list of branches of the form ;; FIXME. (error "Vector QPatterns not implemented yet")) ((consp qpat) - (let ((syma (make-symbol "xcar")) - (symd (make-symbol "xcdr"))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym - (apply-partially #'pcase--split-consp syma symd) - rest) - (let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat))) - ,@matches) - code vars then-rest))) - (pcase--if - `(consp ,sym) - ;; We want to be careful to only add bindings that are used. - ;; The byte-compiler could do that for us, but it would have to pay - ;; attention to the `consp' test in order to figure out that car/cdr - ;; can't signal errors and our byte-compiler is not that clever. - `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) - ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) - ,then-body) - (pcase--u else-rest)))))) + (let* ((syma (make-symbol "xcar")) + (symd (make-symbol "xcdr")) + (splitrest (pcase--split-rest + sym + (apply-partially #'pcase--split-consp syma symd) + rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest)) + (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) + (match ,symd . ,(pcase--upat (cdr qpat))) + ,@matches) + code vars then-rest))) + (pcase--if + `(consp ,sym) + ;; We want to be careful to only add bindings that are used. + ;; The byte-compiler could do that for us, but it would have to pay + ;; attention to the `consp' test in order to figure out that car/cdr + ;; can't signal errors and our byte-compiler is not that clever. + `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) + ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) + ,then-body) + (pcase--u else-rest)))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) + (let* ((splitrest (pcase--split-rest + sym (apply-partially 'pcase--split-equal qpat) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index e81a8b37981..2701d6b940b 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,4 +1,4 @@ -;;; smie.el --- Simple Minded Indentation Engine +;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*- ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -178,7 +178,7 @@ one of those elements share the same precedence level and associativity." ;; Maybe also add (or <elem1> <elem2>...) for things like ;; (exp (exp (or "+" "*" "=" ..) exp)). ;; Basically, make it EBNF (except for the specification of a separator in - ;; the repetition). + ;; the repetition, maybe). (let ((nts (mapcar 'car bnf)) ;Non-terminals (first-ops-table ()) (last-ops-table ()) |