From 43e67019dfc4fb7d3474e0fbedcfec60f2300521 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 11 Feb 2011 14:48:54 -0500 Subject: Make cconv-analyse understand the need for closures. * lisp/emacs-lisp/byte-lexbind.el (byte-compile-lforminfo-analyze): Understand the :fun-body case for catch, save-window-excursion, and condition-case. (byte-compile-maybe-push-heap-environment): No need when nclosures is zero and byte-compile-current-num-closures is -1. * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Fix `fun' that was not renamed to `bytecomp-fun'. * lisp/emacs-lisp/cconv.el (cconv-not-lexical-var-p): New function. (cconv-freevars): Use it. (cconv-closure-convert-rec): Avoid `position'. (cconv-analyse-function): New function. (cconv-analyse-form): Use it. `inclosure' can't be nil any more. Check lexical vars at let-binding time rather than when referenced. For defuns to be in an empty environment and lambdas to take lexical args. Pay attention to the need to build closures in catch, unwind-protect, save-window-excursion, condition-case, and track-mouse. Fix defconst/defvar handling. --- lisp/emacs-lisp/macroexp.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index af8047256e2..bccc60a24e0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -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) @@ -164,6 +166,17 @@ Assumes the caller has bound `macroexpand-all-environment'." (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args))))) + ;; Macro expand compiler macros. + ;; FIXME: Don't depend on CL. + (`(,(and (pred symbolp) fun + (guard (and (eq (get fun 'byte-compile) + 'cl-byte-compile-compiler-macro) + (functionp 'compiler-macroexpand)))) + . ,_) + (let ((newform (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 -- cgit v1.2.3 From 876c194cbac17a6220dbf406b0a602325978011c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 24 Feb 2011 22:27:45 -0500 Subject: Get rid of funvec. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of `byte-constant'. (byte-compile-close-variables, displaying-byte-compile-warnings): Add edebug spec. (byte-compile-toplevel-file-form): New fun, split out of byte-compile-file-form. (byte-compile-from-buffer): Use it to avoid applying cconv multiple times. (byte-compile): Only strip `function' if it's present. (byte-compile-lambda): Add `reserved-csts' argument. Use new lexenv arg of byte-compile-top-level. (byte-compile-reserved-constants): New var. (byte-compile-constants-vector): Obey it. (byte-compile-constants-vector): Handle new `byte-constant' form. (byte-compile-top-level): Add args `lexenv' and `reserved-csts'. (byte-compile-form): Don't check callargs here. (byte-compile-normal-call): Do it here instead. (byte-compile-push-unknown-constant) (byte-compile-resolve-unknown-constant): Remove, unused. (byte-compile-make-closure): Use `make-byte-code' rather than `curry', putting the environment into the "constant" pool. (byte-compile-get-closed-var): Use special byte-constant. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Handle new intermediate special form `internal-make-vector'. (byte-optimize-lapcode): Handle new form of `byte-constant'. * lisp/help-fns.el (describe-function-1): Don't handle funvecs. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Only convert quote to function if the content is a lambda expression, not if it's a closure. * emacs-lisp/eieio-come.el: Remove. * lisp/emacs-lisp/eieio.el: Don't require eieio-comp. (defmethod): Do a bit more work to find the body and wrap it into a function before passing it to eieio-defmethod. (eieio-defmethod): New arg `code' for it. * lisp/emacs-lisp/debug.el (debugger-setup-buffer): Don't hide things in debugger backtrace. * lisp/emacs-lisp/cl-extra.el (cl-macroexpand-all): Use backquotes, and be more careful when quoting a function value. * lisp/emacs-lisp/cconv.el (cconv-freevars): Accept defvar/defconst. (cconv-closure-convert-rec): Catch stray `internal-make-closure'. * lisp/Makefile.in (COMPILE_FIRST): Compile pcase and cconv early. * src/eval.c (Qcurry): Remove. (funcall_funvec): Remove. (funcall_lambda): Move new byte-code handling to reduce impact. Treat all args as lexical in the case of lexbind. (Fcurry): Remove. * src/data.c (Qfunction_vector): Remove. (Ffunvecp): Remove. * src/lread.c (read1): Revert to calling make_byte_code here. (read_vector): Don't call make_byte_code any more. * src/lisp.h (enum pvec_type): Rename back to PVEC_COMPILED. (XSETCOMPILED): Rename back from XSETFUNVEC. (FUNVEC_SIZE): Remove. (FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): Remove. (COMPILEDP): Rename back from FUNVECP. * src/fns.c (Felt): Remove unexplained FUNVEC check. * src/doc.c (Fdocumentation): Don't handle funvec. * src/alloc.c (make_funvec, Ffunvec): Remove. * doc/lispref/vol2.texi (Top): * doc/lispref/vol1.texi (Top): * doc/lispref/objects.texi (Programming Types, Funvec Type, Type Predicates): * doc/lispref/functions.texi (Functions, What Is a Function, FunctionCurrying): * doc/lispref/elisp.texi (Top): Remove mentions of funvec and curry. --- .dir-locals.el | 2 +- doc/lispref/ChangeLog | 8 +++ doc/lispref/elisp.texi | 4 +- doc/lispref/functions.texi | 70 +------------------- doc/lispref/objects.texi | 61 ++++------------- doc/lispref/vol1.texi | 2 +- doc/lispref/vol2.texi | 2 +- etc/NEWS.lexbind | 21 ++---- lisp/ChangeLog | 43 ++++++++++++ lisp/Makefile.in | 6 +- lisp/emacs-lisp/byte-opt.el | 47 ++++++++----- lisp/emacs-lisp/bytecomp.el | 138 ++++++++++++++++++++------------------- lisp/emacs-lisp/cconv.el | 43 +++++------- lisp/emacs-lisp/cl-extra.el | 24 +++---- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/debug.el | 5 +- lisp/emacs-lisp/eieio-comp.el | 145 ----------------------------------------- lisp/emacs-lisp/eieio.el | 45 +++++++++---- lisp/emacs-lisp/macroexp.el | 5 +- lisp/help-fns.el | 22 ------- src/ChangeLog | 56 ++++++++++++++++ src/ChangeLog.funvec | 37 ----------- src/alloc.c | 71 ++------------------ src/bytecode.c | 9 ++- src/data.c | 25 ++----- src/doc.c | 5 -- src/eval.c | 133 +++++++------------------------------ src/fns.c | 25 ++++--- src/image.c | 3 +- src/keyboard.c | 2 +- src/lisp.h | 33 ++-------- src/lread.c | 33 +++------- src/print.c | 6 +- 33 files changed, 380 insertions(+), 753 deletions(-) delete mode 100644 lisp/emacs-lisp/eieio-comp.el delete mode 100644 src/ChangeLog.funvec (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/.dir-locals.el b/.dir-locals.el index f098f3e7460..86410cc8f40 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,6 +1,6 @@ ((nil . ((tab-width . 8) (sentence-end-double-space . t) - (fill-column . 70))) + (fill-column . 79))) (c-mode . ((c-file-style . "GNU"))) ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work. ;; See admin/notes/bugtracker. diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 90eed004d39..c5e445cec38 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,11 @@ +2011-02-25 Stefan Monnier + + * vol2.texi (Top): + * vol1.texi (Top): + * objects.texi (Programming Types, Funvec Type, Type Predicates): + * functions.texi (Functions, What Is a Function, Function Currying): + * elisp.texi (Top): Remove mentions of funvec and curry. + 2011-02-19 Eli Zaretskii * elisp.texi: Sync @dircategory with ../../info/dir. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 8e3498b8b6f..f7c1d55f6ae 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -249,7 +249,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. @@ -464,8 +464,6 @@ Functions * Inline Functions:: Defining functions that the compiler will open code. * Declaring Functions:: Telling the compiler that a function is defined. -* Function Currying:: Making wrapper functions that pre-specify - some arguments. * Function Safety:: Determining whether a function is safe to call. * Related Topics:: Cross-references to specific Lisp primitives that have a special bearing on how functions work. diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index fc56e806cf7..974487382c8 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -23,8 +23,6 @@ define them. of a symbol. * Obsolete Functions:: Declaring functions obsolete. * Inline Functions:: Defining functions that the compiler will open code. -* Function Currying:: Making wrapper functions that pre-specify - some arguments. * Declaring Functions:: Telling the compiler that a function is defined. * Function Safety:: Determining whether a function is safe to call. * Related Topics:: Cross-references to specific Lisp primitives @@ -113,25 +111,7 @@ editors; for Lisp programs, the distinction is normally unimportant. @item byte-code function A @dfn{byte-code function} is a function that has been compiled by the -byte compiler. A byte-code function is actually a special case of a -@dfn{funvec} object (see below). - -@item function vector -A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose -purpose is to define special kinds of functions. @xref{Funvec Type}. - -The exact meaning of the vector elements is determined by the type of -funvec: the most common use is byte-code functions, which have a -list---the argument list---as the first element. Further types of -funvec object are: - -@table @code -@item curry -A curried function. Remaining arguments in the funvec are function to -call, and arguments to prepend to user arguments at the time of the -call; @xref{Function Currying}. -@end table - +byte compiler. @xref{Byte-Code Type}. @end table @defun functionp object @@ -172,11 +152,6 @@ function. For example: @end example @end defun -@defun funvecp object -@code{funvecp} returns @code{t} if @var{object} is a function vector -object (including byte-code objects), and @code{nil} otherwise. -@end defun - @defun subr-arity subr This function provides information about the argument list of a primitive, @var{subr}. The returned value is a pair @@ -1302,49 +1277,6 @@ do for macros. (@xref{Argument Evaluation}.) Inline functions can be used and open-coded later on in the same file, following the definition, just like macros. -@node Function Currying -@section Function Currying -@cindex function currying -@cindex currying -@cindex partial-application - -Function currying is a way to make a new function that calls an -existing function with a partially pre-determined argument list. - -@defun curry function &rest args -Return a function-like object that will append any arguments it is -called with to @var{args}, and call @var{function} with the resulting -list of arguments. - -For example, @code{(curry 'concat "The ")} returns a function that -concatenates @code{"The "} and its arguments. Calling this function -on @code{"end"} returns @code{"The end"}: - -@example -(funcall (curry 'concat "The ") "end") - @result{} "The end" -@end example - -The @dfn{curried function} is useful as an argument to @code{mapcar}: - -@example -(mapcar (curry 'concat "The ") '("big" "red" "balloon")) - @result{} ("The big" "The red" "The balloon") -@end example -@end defun - -Function currying may be implemented in any Lisp by constructing a -@code{lambda} expression, for instance: - -@example -(defun curry (function &rest args) - `(lambda (&rest call-args) - (apply #',function ,@@args call-args))) -@end example - -However in Emacs Lisp, a special curried function object is used for -efficiency. @xref{Funvec Type}. - @node Declaring Functions @section Telling the Compiler that a Function is Defined @cindex function declaration diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index a20c50b63d6..c58d54f13fc 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -156,7 +156,7 @@ latter are unique to Emacs Lisp. * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. @end menu @@ -1313,55 +1313,18 @@ with the name of the subroutine. @end group @end example -@node Funvec Type -@subsection ``Function Vector' Type -@cindex function vector -@cindex funvec +@node Byte-Code Type +@subsection Byte-Code Function Type -A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose -purpose is to define special kinds of functions. You can examine or -modify the contents of a funvec like a normal vector, using the -@code{aref} and @code{aset} functions. +The byte compiler produces @dfn{byte-code function objects}. +Internally, a byte-code function object is much like a vector; however, +the evaluator handles this data type specially when it appears as a +function to be called. @xref{Byte Compilation}, for information about +the byte compiler. -The behavior of a funvec when called is dependent on the kind of -funvec it is, and that is determined by its first element (a -zero-length funvec will signal an error if called): - -@table @asis -@item A list -A funvec with a list as its first element is a byte-compiled function, -produced by the byte compiler; such funvecs are known as -@dfn{byte-code function objects}. @xref{Byte Compilation}, for -information about the byte compiler. - -@item The symbol @code{curry} -A funvec with @code{curry} as its first element is a ``curried function''. - -The second element in such a funvec is the function which is -being curried, and the remaining elements are a list of arguments. - -Calling such a funvec operates by calling the embedded function with -an argument list composed of the arguments in the funvec followed by -the arguments the funvec was called with. @xref{Function Currying}. -@end table - -The printed representation and read syntax for a funvec object is like -that for a vector, with an additional @samp{#} before the opening -@samp{[}. - -@defun funvecp object -@code{funvecp} returns @code{t} if @var{object} is a function vector -object (including byte-code objects), and @code{nil} otherwise. -@end defun - -@defun funvec kind &rest params -@code{funvec} returns a new function vector containing @var{kind} and -@var{params}. @var{kind} determines the type of funvec; it should be -one of the choices listed in the table above. - -Typically you should use the @code{make-byte-code} function to create -byte-code objects, though they are a type of funvec. -@end defun +The printed representation and read syntax for a byte-code function +object is like that for a vector, with an additional @samp{#} before the +opening @samp{[}. @node Autoload Type @subsection Autoload Type @@ -1808,7 +1771,7 @@ with references to further information. @xref{Buffer Basics, bufferp}. @item byte-code-function-p -@xref{Funvec Type, byte-code-function-p}. +@xref{Byte-Code Type, byte-code-function-p}. @item case-table-p @xref{Case Tables, case-table-p}. diff --git a/doc/lispref/vol1.texi b/doc/lispref/vol1.texi index 33671623b51..ad8ff0819ca 100644 --- a/doc/lispref/vol1.texi +++ b/doc/lispref/vol1.texi @@ -269,7 +269,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/doc/lispref/vol2.texi b/doc/lispref/vol2.texi index 8e5c4b2ef8f..7832b3a8614 100644 --- a/doc/lispref/vol2.texi +++ b/doc/lispref/vol2.texi @@ -268,7 +268,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind index 372ee6827cf..bcb56c313f8 100644 --- a/etc/NEWS.lexbind +++ b/etc/NEWS.lexbind @@ -1,6 +1,6 @@ GNU Emacs NEWS -- history of user-visible changes. -Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 +Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2011 Free Software Foundation, Inc. See the end of the file for license conditions. @@ -12,21 +12,12 @@ This file is about changes in the Emacs "lexbind" branch. * Lisp changes in Emacs 23.1 -** New `function vector' type, including function currying -The `function vector', or `funvec' type extends the old -byte-compiled-function vector type to have other uses as well, and -includes existing byte-compiled functions as a special case. The kind -of funvec is determined by the first element: a list is a byte-compiled -function, and a non-nil atom is one of the new extended uses, currently -`curry' for curried functions. See the node `Funvec Type' in the Emacs -Lisp Reference Manual for more information. - -*** New function curry allows constructing `curried functions' -(see the node `Function Currying' in the Emacs Lisp Reference Manual). - -*** New functions funvec and funvecp allow primitive access to funvecs - +** The `lexical-binding' lets code use lexical scoping for local variables. +It is typically set via file-local variables, in which case it applies to +all the code in that file. +** Lexically scoped interpreted functions are represented with a new form +of function value which looks like (closure ENV lambda ARGS &rest BODY). ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f7a62bc8385..ee6944d8e07 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,46 @@ +2011-02-25 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of + `byte-constant'. + (byte-compile-close-variables, displaying-byte-compile-warnings): + Add edebug spec. + (byte-compile-toplevel-file-form): New fun, split out of + byte-compile-file-form. + (byte-compile-from-buffer): Use it to avoid applying cconv + multiple times. + (byte-compile): Only strip `function' if it's present. + (byte-compile-lambda): Add `reserved-csts' argument. + Use new lexenv arg of byte-compile-top-level. + (byte-compile-reserved-constants): New var. + (byte-compile-constants-vector): Obey it. + (byte-compile-constants-vector): Handle new `byte-constant' form. + (byte-compile-top-level): Add args `lexenv' and `reserved-csts'. + (byte-compile-form): Don't check callargs here. + (byte-compile-normal-call): Do it here instead. + (byte-compile-push-unknown-constant) + (byte-compile-resolve-unknown-constant): Remove, unused. + (byte-compile-make-closure): Use `make-byte-code' rather than `curry', + putting the environment into the "constant" pool. + (byte-compile-get-closed-var): Use special byte-constant. + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Handle new + intermediate special form `internal-make-vector'. + (byte-optimize-lapcode): Handle new form of `byte-constant'. + * help-fns.el (describe-function-1): Don't handle funvecs. + * emacs-lisp/macroexp.el (macroexpand-all-1): Only convert quote to + function if the content is a lambda expression, not if it's a closure. + * emacs-lisp/eieio-come.el: Remove. + * emacs-lisp/eieio.el: Don't require eieio-comp. + (defmethod): Do a bit more work to find the body and wrap it into + a function before passing it to eieio-defmethod. + (eieio-defmethod): New arg `code' for it. + * emacs-lisp/debug.el (debugger-setup-buffer): Don't hide things in + debugger backtrace. + * emacs-lisp/cl-extra.el (cl-macroexpand-all): Use backquotes, and be + more careful when quoting a function value. + * emacs-lisp/cconv.el (cconv-freevars): Accept defvar/defconst. + (cconv-closure-convert-rec): Catch stray `internal-make-closure'. + * Makefile.in (COMPILE_FIRST): Compile pcase and cconv early. + 2011-02-21 Stefan Monnier * emacs-lisp/cconv.el (cconv-closure-convert-rec): Let the byte diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 6e28c3f9df8..389d5b154aa 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -83,7 +83,9 @@ BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" COMPILE_FIRST = \ $(lisp)/emacs-lisp/bytecomp.elc \ $(lisp)/emacs-lisp/byte-opt.elc \ + $(lisp)/emacs-lisp/pcase.elc \ $(lisp)/emacs-lisp/macroexp.elc \ + $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/emacs-lisp/autoload.elc # The actual Emacs command run in the targets below. @@ -203,7 +205,7 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - @$(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ + $(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $(THEFILE) @@ -220,7 +222,7 @@ compile-onefile: # cannot have prerequisites. .el.elc: @echo Compiling $< - @$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + $(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $< .PHONY: compile-first compile-main compile compile-always diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c9cc4618967..342dd8b71d1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -531,7 +531,11 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) + ((eq fn 'internal-make-closure) + form) + ((not (symbolp fn)) + (debug) (byte-compile-warn "`%s' is a malformed function" (prin1-to-string fn)) form) @@ -1472,7 +1476,8 @@ 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-stack-ref)) + byte-current-buffer byte-stack-ref ;; byte-closed-var + )) (defconst byte-compile-side-effect-free-ops (nconc @@ -1680,11 +1685,18 @@ 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)) + (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 (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) + (eq (car lap1) 'byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) (byte-compile-log-lap " %s %s\t-->\t" lap0 lap1) (setq rest (cdr rest) @@ -1696,11 +1708,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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 + ;; 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. @@ -1877,18 +1889,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 goto " @@ -1897,8 +1912,8 @@ 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 diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 771306bb0e6..6bc2b3b5617 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -794,10 +794,13 @@ CONST2 may be evaulated multiple times." ;; goto (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) (push bytes patchlist)) - ((and (consp off) - ;; Variable or constant reference - (progn (setq off (cdr off)) - (eq op 'byte-constant))) + ((or (and (consp off) + ;; Variable or constant reference + (progn + (setq off (cdr off)) + (eq op 'byte-constant))) + (and (eq op 'byte-constant) ;; 'byte-closed-var + (integerp off))) ;; constant ref (if (< off byte-constant-limit) (byte-compile-push-bytecodes (+ byte-constant off) @@ -1480,6 +1483,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 @@ -1510,6 +1514,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) @@ -1930,7 +1935,7 @@ With argument ARG, insert value in current buffer after the form." (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 @@ -2041,8 +2046,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) @@ -2182,12 +2187,17 @@ list that represents a doc string reference. byte-compile-maxdepth 0 byte-compile-output nil)))) -(defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - bytecomp-handler) +;; byte-hunk-handlers cannot call this! +(defun byte-compile-toplevel-file-form (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. (setq form (macroexpand-all form byte-compile-macro-environment)) (if lexical-binding (setq form (cconv-closure-convert form))) + (byte-compile-file-form form))) + +;; byte-hunk-handlers can call this. +(defun byte-compile-file-form (form) + (let (bytecomp-handler) (cond ((not (consp form)) (byte-compile-keep-pending form)) ((and (symbolp (car form)) @@ -2541,7 +2551,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if lexical-binding (setq fun (cconv-closure-convert fun))) ;; Get rid of the `function' quote added by the `lambda' macro. - (setq fun (cadr fun)) + (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2654,7 +2664,7 @@ 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 (bytecomp-fun &optional add-lambda reserved-csts) (if add-lambda (setq bytecomp-fun (cons 'lambda bytecomp-fun)) (unless (eq 'lambda (car-safe bytecomp-fun)) @@ -2702,14 +2712,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let* ((byte-compile-lexical-environment - ;; 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 bytecomp-fun))) - (compiled - (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) + (let* ((compiled + (byte-compile-top-level (cons 'progn bytecomp-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 + bytecomp-fun)) + reserved-csts))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) (apply 'make-byte-code @@ -2740,6 +2752,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; A simple lambda is just a constant. (byte-compile-constant code))) +(defvar byte-compile-reserved-constants 0) + (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. ;; This modifies the constants from (const . nil) to (const . offset). @@ -2748,7 +2762,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 @@ -2759,11 +2773,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 @@ -2772,7 +2790,8 @@ 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, @@ -2783,9 +2802,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) - (byte-compile-lexical-environment - (when (eq output-type 'lambda) - byte-compile-lexical-environment)) + (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))) @@ -2904,6 +2922,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list bytecomp-body)))) +;; FIXME: Like defsubst's, this hunk-handler won't be called any more +;; because the macro is expanded away before we see it. (put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) (defun byte-compile-declare-function (form) (push (cons (nth 1 form) @@ -2950,12 +2970,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (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 (fboundp (car form)) (eq (car-safe (symbol-function (car form))) 'macro)) (byte-compile-report-error @@ -2985,6 +2999,13 @@ That command is designed for interactive use only" bytecomp-fn)) (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)) + (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) @@ -3037,7 +3058,7 @@ If BINDING is non-nil, VAR is being bound." (boundp var) (memq var byte-compile-bound-variables) (memq var byte-compile-free-references)) - (byte-compile-warn "reference to free variable `%s'" var) + (byte-compile-warn "reference to free variable `%S'" var) (push var byte-compile-free-references)) (byte-compile-dynamic-variable-op 'byte-varref var)))) @@ -3082,26 +3103,6 @@ If BINDING is non-nil, VAR is being bound." (defun byte-compile-push-constant (const) (let ((for-effect nil)) (inline (byte-compile-constant const)))) - -(defun byte-compile-push-unknown-constant (&optional id) - "Generate code to push a `constant' who's value isn't known yet. -A tag is returned which may then later be passed to -`byte-compile-resolve-unknown-constant' to finalize the value. -The optional argument ID is a tag returned by an earlier call to -`byte-compile-push-unknown-constant', in which case the same constant is -pushed again." - (unless id - (setq id (list (make-symbol "unknown"))) - (push id byte-compile-constants)) - (byte-compile-out 'byte-constant id) - id) - -(defun byte-compile-resolve-unknown-constant (id value) - "Give an `unknown constant' a value. -ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE -is the value it should have." - (setcar id value)) - ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3345,18 +3346,23 @@ discarding." (defconst byte-compile--env-var (make-symbol "env")) (defun byte-compile-make-closure (form) - ;; FIXME: don't use `curry'! - (byte-compile-form - (unless for-effect - `(curry (function (lambda (,byte-compile--env-var . ,(nth 1 form)) - . ,(nthcdr 3 form))) - (vector . ,(nth 2 form)))) - for-effect)) + (if for-effect (setq 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-form (unless for-effect - `(aref ,byte-compile--env-var ,(nth 1 form))) - for-effect)) + (if for-effect (setq for-effect nil) + (byte-compile-out 'byte-constant ;; byte-closed-var + (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 diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 6aa4b7e0a61..bc7ecb1ad55 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -47,19 +47,14 @@ ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) ;; if the function is suitable for lambda lifting (if all calls are known) ;; -;; (lambda (v1 ...) ... fv ...) => -;; (curry (lambda (env v1 ...) ... env ...) env) -;; if the function has only 1 free variable -;; -;; and finally -;; (lambda (v1 ...) ... fv1 fv2 ...) => -;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2)) -;; if the function has 2 or more free variables. +;; (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 it's definition with list: (list val) and we also replace +;; 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. ;; @@ -71,15 +66,12 @@ ;;; Code: ;;; TODO: +;; - pay attention to `interactive': its arg is run in an empty env. ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. ;; - Change new byte-code representation, so it directly gives the ;; number of mandatory and optional arguments as well as whether or ;; not there's a &rest arg. -;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp -;; should turn into building corresponding byte-code function. -;; - don't use `curry', instead build a new compiled-byte-code object -;; (merge the closure env into the static constants pool). ;; - warn about unused lexical vars. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. ;; - new byte codes for unwind-protect, catch, and condition-case so that @@ -184,8 +176,8 @@ Returns a list of free variables." ;; We call cconv-freevars only for functions(lambdas) ;; defun, defconst, defvar are not allowed to be inside ;; a function (lambda). - ;; FIXME: should be a byte-compile-report-error! - (error "Invalid form: %s inside a function" sym)) + ;; (error "Invalid form: %s inside a function" sym) + (cconv-freevars `(progn ,@(cddr form)) fvrs)) (`(,_ . ,body-forms) ; First element is (like) a function. (dolist (exp body-forms) @@ -537,6 +529,9 @@ Returns a form where all lambdas don't have any free variables." `(internal-make-closure ,vars ,envector . ,body-forms-new))))) + (`(internal-make-closure . ,_) + (error "Internal byte-compiler error: cconv called twice")) + (`(function . ,_) form) ; Same as quote. ;defconst, defvar @@ -599,20 +594,18 @@ Returns a form where all lambdas don't have any free variables." ;condition-case (`(condition-case ,var ,protected-form . ,handlers) - (let ((handlers-new '()) - (newform (cconv-closure-convert-rec + (let ((newform (cconv-closure-convert-rec `(function (lambda () ,protected-form)) emvrs fvrs envs lmenvs))) (setq fvrs (remq var fvrs)) - (dolist (handler handlers) - (push (list (car handler) - (cconv-closure-convert-rec - `(function (lambda (,(or var cconv--dummy-var)) - ,@(cdr handler))) - emvrs fvrs envs lmenvs)) - handlers-new)) `(condition-case :fun-body ,newform - ,@(nreverse handlers-new)))) + ,@(mapcar (lambda (handler) + (list (car handler) + (cconv-closure-convert-rec + (let ((arg (or var cconv--dummy-var))) + `(function (lambda (,arg) ,@(cdr handler)))) + emvrs fvrs envs lmenvs))) + handlers)))) (`(,(and head (or `catch `unwind-protect)) ,form . ,body) `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 12dafe274b9..7468a0237cf 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -766,21 +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 'quote - (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 bd50c75bcc3..df9460154e8 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" "2bfbae6523c842d511b8c8d88658825a") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 88633eaaa46..0b2ea81fb64 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -269,8 +269,9 @@ That buffer should be current already." (setq buffer-undo-list t) (let ((standard-output (current-buffer)) (print-escape-newlines t) - (print-level 8) - (print-length 50)) + (print-level 1000) ;8 + ;; (print-length 50) + ) (backtrace)) (goto-char (point-min)) (delete-region (point) diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el deleted file mode 100644 index 244c4318425..00000000000 --- a/lisp/emacs-lisp/eieio-comp.el +++ /dev/null @@ -1,145 +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 -;; 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 . - -;;; 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 'eieio-byte-compile-file-form-defmethod) - -(defun eieio-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 (eieio-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 "#") 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) - ;; FIXME: This relies on compiler's internal. Make sure it still - ;; works with lexical-binding code. Maybe calling `byte-compile' - ;; would be preferable. - (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 eieio-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 bd768dbdb9f..4e443452d8b 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.") @@ -123,6 +122,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 a `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 +181,6 @@ Stored outright without modifications or stripping.") (t key) ;; already generic.. maybe. )) -;; How to specialty compile stuff. -(autoload 'eieio-byte-compile-file-form-defmethod "eieio-comp" - "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -1293,9 +1289,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 @@ -1349,10 +1371,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/macroexp.el b/lisp/emacs-lisp/macroexp.el index bccc60a24e0..781195d034a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -153,13 +153,14 @@ 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) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 49767e6e9d3..b488bc40acd 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -363,13 +363,6 @@ suitable file is found, return nil." (concat beg "built-in function"))) ((byte-code-function-p def) (concat beg "compiled Lisp function")) - ((and (funvecp def) (eq (aref def 0) 'curry)) - (if (symbolp (aref def 1)) - (format "a curried function calling `%s'" (aref def 1)) - "a curried function")) - ((funvecp def) - (format "a function-vector (funvec) of type `%s'" - (aref def 0))) ((symbolp def) (while (and (fboundp def) (symbolp (symbol-function def))) @@ -510,21 +503,6 @@ suitable file is found, return nil." ((or (stringp def) (vectorp def)) (format "\nMacro: %s" (format-kbd-macro def))) - ((and (funvecp def) (eq (aref def 0) 'curry)) - ;; Describe a curried-function's function and args - (let ((slot 0)) - (mapconcat (lambda (arg) - (setq slot (1+ slot)) - (cond - ((= slot 1) "") - ((= slot 2) - (format " Function: %S" arg)) - (t - (format "Argument %d: %S" - (- slot 3) arg)))) - def - "\n"))) - ((funvecp def) nil) (t "[Missing arglist. Please make a bug report.]"))) (high (help-highlight-arguments use doc))) (let ((fill-begin (point))) diff --git a/src/ChangeLog b/src/ChangeLog index d522b6c55dc..e7902b8c083 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,23 @@ +2011-02-25 Stefan Monnier + + * eval.c (Qcurry): Remove. + (funcall_funvec): Remove. + (funcall_lambda): Move new byte-code handling to reduce impact. + Treat all args as lexical in the case of lexbind. + (Fcurry): Remove. + * data.c (Qfunction_vector): Remove. + (Ffunvecp): Remove. + * lread.c (read1): Revert to calling make_byte_code here. + (read_vector): Don't call make_byte_code any more. + * lisp.h (enum pvec_type): Rename back to PVEC_COMPILED. + (XSETCOMPILED): Rename back from XSETFUNVEC. + (FUNVEC_SIZE): Remove. + (FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): Remove. + (COMPILEDP): Rename back from FUNVECP. + * fns.c (Felt): Remove unexplained FUNVEC check. + * doc.c (Fdocumentation): Don't handle funvec. + * alloc.c (make_funvec, Ffunvec): Remove. + 2011-02-21 Stefan Monnier * bytecode.c (exec_byte_code): Change stack_ref and stack_set to use @@ -113,6 +133,42 @@ Merge funvec patch. +2004-05-20 Miles Bader + + * lisp.h: Declare make_funvec and Ffunvec. + (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'. + (XSETFUNVEC): Rename from `XSETCOMPILED'. + (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros. + (COMPILEDP): Define in terms of funvec macros. + (FUNVECP, GC_FUNVECP): Rename from `COMPILEDP' & `GC_COMPILEDP'. + (FUNCTIONP): Use FUNVECP instead of COMPILEDP. + * alloc.c (make_funvec, funvec): New functions. + (Fmake_byte_code): Make sure the first element is a list. + + * eval.c (Qcurry): New variable. + (funcall_funvec, Fcurry): New functions. + (syms_of_eval): Initialize them. + (funcall_lambda): Handle non-bytecode funvec objects by calling + funcall_funvec. + (Ffuncall, Feval): Use FUNVECP insetad of COMPILEDP. + * lread.c (read1): Return result of read_vector for `#[' syntax + directly; read_vector now does any extra work required. + (read_vector): Handle both funvec and byte-code objects, converting the + type as necessary. `bytecodeflag' argument is now called + `read_funvec'. + * data.c (Ffunvecp): New function. + * doc.c (Fdocumentation): Return nil for unknown funvecs. + * fns.c (mapcar1, Felt, concat): Allow funvecs. + + * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled' + operators. + * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise. + * keyboard.c (Fcommand_execute): Likewise. + * image.c (parse_image_spec): Likewise. + * fns.c (Flength, concat, internal_equal): Likewise. + * data.c (Faref, Ftype_of): Likewise. + * print.c (print_preprocess, print_object): Likewise. + 2004-04-10 Miles Bader * eval.c (Fspecialp): New function. diff --git a/src/ChangeLog.funvec b/src/ChangeLog.funvec deleted file mode 100644 index 098539f1dd9..00000000000 --- a/src/ChangeLog.funvec +++ /dev/null @@ -1,37 +0,0 @@ -2004-05-20 Miles Bader - - * lisp.h: Declare make_funvec and Ffunvec. - (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'. - (XSETFUNVEC): Renamed from `XSETCOMPILED'. - (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros. - (COMPILEDP): Define in terms of funvec macros. - (FUNVECP, GC_FUNVECP): Renamed from `COMPILEDP' & `GC_COMPILEDP'. - (FUNCTIONP): Use FUNVECP instead of COMPILEDP. - * alloc.c (make_funvec, funvec): New functions. - (Fmake_byte_code): Make sure the first element is a list. - - * eval.c (Qcurry): New variable. - (funcall_funvec, Fcurry): New functions. - (syms_of_eval): Initialize them. - (funcall_lambda): Handle non-bytecode funvec objects by calling - funcall_funvec. - (Ffuncall, Feval): Use FUNVECP insetad of COMPILEDP. - * lread.c (read1): Return result of read_vector for `#[' syntax - directly; read_vector now does any extra work required. - (read_vector): Handle both funvec and byte-code objects, converting the - type as necessary. `bytecodeflag' argument is now called - `read_funvec'. - * data.c (Ffunvecp): New function. - * doc.c (Fdocumentation): Return nil for unknown funvecs. - * fns.c (mapcar1, Felt, concat): Allow funvecs. - - * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled' - operators. - * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise. - * keyboard.c (Fcommand_execute): Likewise. - * image.c (parse_image_spec): Likewise. - * fns.c (Flength, concat, internal_equal): Likewise. - * data.c (Faref, Ftype_of): Likewise. - * print.c (print_preprocess, print_object): Likewise. - -;; arch-tag: f35a6a00-4a11-4739-a4b6-9cf98296f315 diff --git a/src/alloc.c b/src/alloc.c index 81a17b5c13b..0b7db7ec627 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2924,37 +2924,6 @@ See also the function `vector'. */) } -/* Return a new `function vector' containing KIND as the first element, - followed by NUM_NIL_SLOTS nil elements, and further elements copied from - the vector PARAMS of length NUM_PARAMS (so the total length of the - resulting vector is 1 + NUM_NIL_SLOTS + NUM_PARAMS). - - If NUM_PARAMS is zero, then PARAMS may be NULL. - - A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp. - See the function `funvec' for more detail. */ - -Lisp_Object -make_funvec (Lisp_Object kind, int num_nil_slots, int num_params, - Lisp_Object *params) -{ - int param_index; - Lisp_Object funvec; - - funvec = Fmake_vector (make_number (1 + num_nil_slots + num_params), Qnil); - - ASET (funvec, 0, kind); - - for (param_index = 0; param_index < num_params; param_index++) - ASET (funvec, 1 + num_nil_slots + param_index, params[param_index]); - - XSETPVECTYPE (XVECTOR (funvec), PVEC_FUNVEC); - XSETFUNVEC (funvec, XVECTOR (funvec)); - - return funvec; -} - - DEFUN ("vector", Fvector, Svector, 0, MANY, 0, doc: /* Return a newly created vector with specified arguments as elements. Any number of arguments, even zero arguments, are allowed. @@ -2974,27 +2943,6 @@ usage: (vector &rest OBJECTS) */) } -DEFUN ("funvec", Ffunvec, Sfunvec, 1, MANY, 0, - doc: /* Return a newly created `function vector' of type KIND. -A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp. -KIND indicates the kind of funvec, and determines its behavior when called. -The meaning of the remaining arguments depends on KIND. Currently -implemented values of KIND, and their meaning, are: - - A list -- A byte-compiled function. See `make-byte-code' for the usual - way to create byte-compiled functions. - - `curry' -- A curried function. Remaining arguments are a function to - call, and arguments to prepend to user arguments at the - time of the call; see the `curry' function. - -usage: (funvec KIND &rest PARAMS) */) - (int nargs, Lisp_Object *args) -{ - return make_funvec (args[0], 0, nargs - 1, args + 1); -} - - DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the arglist, bytecode-string, constant vector, @@ -3008,10 +2956,6 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT register int index; register struct Lisp_Vector *p; - /* Make sure the arg-list is really a list, as that's what's used to - distinguish a byte-compiled object from other funvecs. */ - CHECK_LIST (args[0]); - XSETFASTINT (len, nargs); if (!NILP (Vpurify_flag)) val = make_pure_vector ((EMACS_INT) nargs); @@ -3033,8 +2977,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } - XSETPVECTYPE (p, PVEC_FUNVEC); - XSETFUNVEC (val, p); + XSETPVECTYPE (p, PVEC_COMPILED); + XSETCOMPILED (val, p); return val; } @@ -4817,7 +4761,7 @@ Does not copy symbols. Copies strings without text properties. */) obj = make_pure_string (SSDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); - else if (FUNVECP (obj) || VECTORP (obj)) + else if (COMPILEDP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; register EMACS_INT i; @@ -4829,10 +4773,10 @@ Does not copy symbols. Copies strings without text properties. */) vec = XVECTOR (make_pure_vector (size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); - if (FUNVECP (obj)) + if (COMPILEDP (obj)) { - XSETPVECTYPE (vec, PVEC_FUNVEC); - XSETFUNVEC (obj, vec); + XSETPVECTYPE (vec, PVEC_COMPILED); + XSETCOMPILED (obj, vec); } else XSETVECTOR (obj, vec); @@ -5418,7 +5362,7 @@ mark_object (Lisp_Object arg) } else if (SUBRP (obj)) break; - else if (FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) + else if (COMPILEDP (obj)) /* We could treat this just like a vector, but it is better to save the COMPILED_CONSTANTS element for last and avoid recursion there. */ @@ -6320,7 +6264,6 @@ The time is in seconds as a floating point value. */); defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); - defsubr (&Sfunvec); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); diff --git a/src/bytecode.c b/src/bytecode.c index 639c543dbf9..464bc3d12de 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE 1 */ +/* #define BYTE_CODE_SAFE */ /* #define BYTE_CODE_METER */ @@ -1720,8 +1720,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, break; #endif + case 0: + /* Actually this is Bstack_ref with offset 0, but we use Bdup + for that instead. */ + /* case Bstack_ref: */ + abort (); + /* Handy byte-codes for lexical binding. */ - /* case Bstack_ref: */ /* Use `dup' instead. */ case Bstack_ref+1: case Bstack_ref+2: case Bstack_ref+3: diff --git a/src/data.c b/src/data.c index ecedba24101..186e9cb9859 100644 --- a/src/data.c +++ b/src/data.c @@ -84,7 +84,7 @@ static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; Lisp_Object Qwindow; static Lisp_Object Qfloat, Qwindow_configuration; Lisp_Object Qprocess; -static Lisp_Object Qcompiled_function, Qfunction_vector, Qbuffer, Qframe, Qvector; +static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; @@ -194,11 +194,8 @@ for example, (type-of 1) returns `integer'. */) return Qwindow; if (SUBRP (object)) return Qsubr; - if (FUNVECP (object)) - if (FUNVEC_COMPILED_P (object)) - return Qcompiled_function; - else - return Qfunction_vector; + if (COMPILEDP (object)) + return Qcompiled_function; if (BUFFERP (object)) return Qbuffer; if (CHAR_TABLE_P (object)) @@ -397,13 +394,6 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, return Qnil; } -DEFUN ("funvecp", Ffunvecp, Sfunvecp, 1, 1, 0, - doc: /* Return t if OBJECT is a `function vector' object. */) - (Lisp_Object object) -{ - return FUNVECP (object) ? Qt : Qnil; -} - DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, doc: /* Return t if OBJECT is a character or a string. */) (register Lisp_Object object) @@ -2113,9 +2103,9 @@ or a byte-code object. IDX starts at 0. */) { int size = 0; if (VECTORP (array)) - size = ASIZE (array); - else if (FUNVECP (array)) - size = FUNVEC_SIZE (array); + size = XVECTOR (array)->size; + else if (COMPILEDP (array)) + size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; else wrong_type_argument (Qarrayp, array); @@ -3180,7 +3170,6 @@ syms_of_data (void) Qwindow = intern_c_string ("window"); /* Qsubr = intern_c_string ("subr"); */ Qcompiled_function = intern_c_string ("compiled-function"); - Qfunction_vector = intern_c_string ("function-vector"); Qbuffer = intern_c_string ("buffer"); Qframe = intern_c_string ("frame"); Qvector = intern_c_string ("vector"); @@ -3206,7 +3195,6 @@ syms_of_data (void) staticpro (&Qwindow); /* staticpro (&Qsubr); */ staticpro (&Qcompiled_function); - staticpro (&Qfunction_vector); staticpro (&Qbuffer); staticpro (&Qframe); staticpro (&Qvector); @@ -3243,7 +3231,6 @@ syms_of_data (void) defsubr (&Smarkerp); defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); - defsubr (&Sfunvecp); defsubr (&Schar_or_string_p); defsubr (&Scar); defsubr (&Scdr); diff --git a/src/doc.c b/src/doc.c index 834321108b5..de20edb2d98 100644 --- a/src/doc.c +++ b/src/doc.c @@ -357,11 +357,6 @@ string is passed through `substitute-command-keys'. */) else return Qnil; } - else if (FUNVECP (fun)) - { - /* Unless otherwise handled, funvecs have no documentation. */ - return Qnil; - } else if (STRINGP (fun) || VECTORP (fun)) { return build_string ("Keyboard macro."); diff --git a/src/eval.c b/src/eval.c index 63484d40e1b..869d70e3d7f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -60,7 +60,6 @@ Lisp_Object Qinhibit_quit; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; -Lisp_Object Qcurry; Lisp_Object Qinternal_interpreter_environment, Qclosure; Lisp_Object Qdebug; @@ -2405,7 +2404,7 @@ eval_sub (Lisp_Object form) } } } - else if (FUNVECP (fun)) + else if (COMPILEDP (fun)) val = apply_lambda (fun, original_args); else { @@ -2890,7 +2889,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, if (SUBRP (object)) return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil; - else if (FUNVECP (object)) + else if (COMPILEDP (object)) return Qt; else if (CONSP (object)) { @@ -3034,7 +3033,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } } } - else if (FUNVECP (fun)) + else if (COMPILEDP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3107,54 +3106,6 @@ apply_lambda (Lisp_Object fun, Lisp_Object args) return tem; } - -/* Call a non-bytecode funvec object FUN, on the argments in ARGS (of - length NARGS). */ - -static Lisp_Object -funcall_funvec (Lisp_Object fun, int nargs, Lisp_Object *args) -{ - int size = FUNVEC_SIZE (fun); - Lisp_Object tag = (size > 0 ? AREF (fun, 0) : Qnil); - - if (EQ (tag, Qcurry)) - { - /* A curried function is a way to attach arguments to a another - function. The first element of the vector is the identifier - `curry', the second is the wrapped function, and remaining - elements are the attached arguments. */ - int num_curried_args = size - 2; - /* Offset of the curried and user args in the final arglist. Curried - args are first in the new arg vector, after the function. User - args follow. */ - int curried_args_offs = 1; - int user_args_offs = curried_args_offs + num_curried_args; - /* The curried function and arguments. */ - Lisp_Object *curry_params = XVECTOR (fun)->contents + 1; - /* The arguments in the curry vector. */ - Lisp_Object *curried_args = curry_params + 1; - /* The number of arguments with which we'll call funcall, and the - arguments themselves. */ - int num_funcall_args = 1 + num_curried_args + nargs; - Lisp_Object *funcall_args - = (Lisp_Object *) alloca (num_funcall_args * sizeof (Lisp_Object)); - - /* First comes the real function. */ - funcall_args[0] = curry_params[0]; - - /* Then the arguments in the appropriate order. */ - memcpy (funcall_args + curried_args_offs, curried_args, - num_curried_args * sizeof (Lisp_Object)); - memcpy (funcall_args + user_args_offs, args, - nargs * sizeof (Lisp_Object)); - - return Ffuncall (num_funcall_args, funcall_args); - } - else - xsignal1 (Qinvalid_function, fun); -} - - /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR and return the result of evaluation. FUN must be either a lambda-expression or a compiled-code object. */ @@ -3167,34 +3118,6 @@ funcall_lambda (Lisp_Object fun, int nargs, int count = SPECPDL_INDEX (); int i, optional, rest; - if (COMPILEDP (fun) - && FUNVEC_SIZE (fun) > COMPILED_PUSH_ARGS - && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS])) - /* A byte-code object with a non-nil `push args' slot means we - shouldn't bind any arguments, instead just call the byte-code - interpreter directly; it will push arguments as necessary. - - Byte-code objects with either a non-existant, or a nil value for - the `push args' slot (the default), have dynamically-bound - arguments, and use the argument-binding code below instead (as do - all interpreted functions, even lexically bound ones). */ - { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - return exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - AREF (fun, COMPILED_ARGLIST), - nargs, arg_vector); - } - - if (FUNVECP (fun) && !FUNVEC_COMPILED_P (fun)) - /* Byte-compiled functions are handled directly below, but we - call other funvec types via funcall_funvec. */ - return funcall_funvec (fun, nargs, arg_vector); - if (CONSP (fun)) { if (EQ (XCAR (fun), Qclosure)) @@ -3213,6 +3136,27 @@ funcall_lambda (Lisp_Object fun, int nargs, } else if (COMPILEDP (fun)) { + if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_PUSH_ARGS + && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS])) + /* A byte-code object with a non-nil `push args' slot means we + shouldn't bind any arguments, instead just call the byte-code + interpreter directly; it will push arguments as necessary. + + Byte-code objects with either a non-existant, or a nil value for + the `push args' slot (the default), have dynamically-bound + arguments, and use the argument-binding code below instead (as do + all interpreted functions, even lexically bound ones). */ + { + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + return exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + AREF (fun, COMPILED_ARGLIST), + nargs, arg_vector); + } syms_left = AREF (fun, COMPILED_ARGLIST); lexenv = Qnil; } @@ -3248,11 +3192,7 @@ funcall_lambda (Lisp_Object fun, int nargs, val = Qnil; /* Bind the argument. */ - if (!NILP (lexenv) && SYMBOLP (next) - /* FIXME: there's no good reason to allow dynamic-scoping - on function arguments, other than consistency with let. */ - && !XSYMBOL (next)->declared_special - && NILP (Fmemq (next, Vinternal_interpreter_environment))) + if (!NILP (lexenv) && SYMBOLP (next)) /* Lexically bind NEXT by adding it to the lexenv alist. */ lexenv = Fcons (Fcons (next, val), lexenv); else @@ -3532,24 +3472,6 @@ context where binding is lexical by default. */) -DEFUN ("curry", Fcurry, Scurry, 1, MANY, 0, - doc: /* Return FUN curried with ARGS. -The result is a function-like object that will append any arguments it -is called with to ARGS, and call FUN with the resulting list of arguments. - -For instance: - (funcall (curry '+ 3 4 5) 2) is the same as (funcall '+ 3 4 5 2) -and: - (mapcar (curry 'concat "The ") '("a" "b" "c")) - => ("The a" "The b" "The c") - -usage: (curry FUN &rest ARGS) */) - (int nargs, Lisp_Object *args) -{ - return make_funvec (Qcurry, 0, nargs, args); -} - - DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. The debugger is entered when that frame exits, if the flag is non-nil. */) @@ -3764,9 +3686,6 @@ before making `inhibit-quit' nil. */); Qclosure = intern_c_string ("closure"); staticpro (&Qclosure); - Qcurry = intern_c_string ("curry"); - staticpro (&Qcurry); - Qdebug = intern_c_string ("debug"); staticpro (&Qdebug); @@ -3901,11 +3820,9 @@ alist of active lexical bindings. */); defsubr (&Srun_hook_with_args_until_success); defsubr (&Srun_hook_with_args_until_failure); defsubr (&Sfetch_bytecode); - defsubr (&Scurry); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); - defsubr (&Scurry); defsubr (&Sspecial_variable_p); defsubr (&Sfunctionp); } diff --git a/src/fns.c b/src/fns.c index 5748c3d6e02..b800846b781 100644 --- a/src/fns.c +++ b/src/fns.c @@ -127,8 +127,8 @@ To get the number of bytes, use `string-bytes'. */) XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); - else if (FUNVECP (sequence)) - XSETFASTINT (val, FUNVEC_SIZE (sequence)); + else if (COMPILEDP (sequence)) + XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) { i = 0; @@ -488,7 +488,7 @@ concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_speci { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) - || FUNVECP (this) || BOOL_VECTOR_P (this))) + || COMPILEDP (this) || BOOL_VECTOR_P (this))) wrong_type_argument (Qsequencep, this); } @@ -512,7 +512,7 @@ concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_speci Lisp_Object ch; EMACS_INT this_len_byte; - if (VECTORP (this) || FUNVECP (this)) + if (VECTORP (this) || COMPILEDP (this)) for (i = 0; i < len; i++) { ch = AREF (this, i); @@ -1311,9 +1311,7 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, return Fcar (Fnthcdr (n, sequence)); /* Faref signals a "not array" error, so check here. */ - if (! FUNVECP (sequence)) - CHECK_ARRAY (sequence, Qsequencep); - + CHECK_ARRAY (sequence, Qsequencep); return Faref (sequence, n); } @@ -2092,14 +2090,13 @@ internal_equal (register Lisp_Object o1, register Lisp_Object o2, int depth, int if (WINDOW_CONFIGURATIONP (o1)) return compare_window_configurations (o1, o2, 0); - /* Aside from them, only true vectors, char-tables, function vectors, - and fonts (font-spec, font-entity, font-ojbect) are sensible to - compare, so eliminate the others now. */ + /* Aside from them, only true vectors, char-tables, compiled + functions, and fonts (font-spec, font-entity, font-ojbect) + are sensible to compare, so eliminate the others now. */ if (size & PSEUDOVECTOR_FLAG) { - if (!(size & (PVEC_FUNVEC - | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE - | PVEC_FONT))) + if (!(size & (PVEC_COMPILED + | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -2302,7 +2299,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */ - if (VECTORP (seq) || FUNVECP (seq)) + if (VECTORP (seq) || COMPILEDP (seq)) { for (i = 0; i < leni; i++) { diff --git a/src/image.c b/src/image.c index f4a50e92ab1..a7c6346f62c 100644 --- a/src/image.c +++ b/src/image.c @@ -835,8 +835,9 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, case IMAGE_FUNCTION_VALUE: value = indirect_function (value); + /* FIXME: Shouldn't we use Ffunctionp here? */ if (SUBRP (value) - || FUNVECP (value) + || COMPILEDP (value) || (CONSP (value) && EQ (XCAR (value), Qlambda))) break; return 0; diff --git a/src/keyboard.c b/src/keyboard.c index 1f14af78844..78aa1cfea77 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10179,7 +10179,7 @@ a special event, so ignore the prefix argument and don't clear it. */) return Fexecute_kbd_macro (final, prefixarg, Qnil); } - if (CONSP (final) || SUBRP (final) || FUNVECP (final)) + if (CONSP (final) || SUBRP (final) || COMPILEDP (final)) /* Don't call Fcall_interactively directly because we want to make sure the backtrace has an entry for `call-interactively'. For the same reason, pass `cmd' rather than `final'. */ diff --git a/src/lisp.h b/src/lisp.h index badeb4258fb..223cdbc92f0 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -349,7 +349,7 @@ enum pvec_type PVEC_NORMAL_VECTOR = 0, PVEC_PROCESS = 0x200, PVEC_FRAME = 0x400, - PVEC_FUNVEC = 0x800, + PVEC_COMPILED = 0x800, PVEC_WINDOW = 0x1000, PVEC_WINDOW_CONFIGURATION = 0x2000, PVEC_SUBR = 0x4000, @@ -607,7 +607,7 @@ extern Lisp_Object make_number (EMACS_INT); #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) -#define XSETFUNVEC(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FUNVEC)) +#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) @@ -623,9 +623,6 @@ extern Lisp_Object make_number (EMACS_INT); eassert ((IDX) >= 0 && (IDX) < ASIZE (ARRAY)), \ AREF ((ARRAY), (IDX)) = (VAL)) -/* Return the size of the psuedo-vector object FUNVEC. */ -#define FUNVEC_SIZE(funvec) (ASIZE (funvec) & PSEUDOVECTOR_SIZE_MASK) - /* Convenience macros for dealing with Lisp strings. */ #define SDATA(string) (XSTRING (string)->data + 0) @@ -1474,7 +1471,7 @@ struct Lisp_Float typedef unsigned char UCHAR; #endif -/* Meanings of slots in a byte-compiled function vector: */ +/* Meanings of slots in a Lisp_Compiled: */ #define COMPILED_ARGLIST 0 #define COMPILED_BYTECODE 1 @@ -1484,24 +1481,6 @@ typedef unsigned char UCHAR; #define COMPILED_INTERACTIVE 5 #define COMPILED_PUSH_ARGS 6 -/* Return non-zero if TAG, the first element from a funvec object, refers - to a byte-code object. Byte-code objects are distinguished from other - `funvec' objects by having a (possibly empty) list as their first - element -- other funvec types use a non-nil symbol there. */ -#define FUNVEC_COMPILED_TAG_P(tag) \ - (NILP (tag) || CONSP (tag)) - -/* Return non-zero if FUNVEC, which should be a `funvec' object, is a - byte-compiled function. Byte-compiled function are funvecs with the - arglist as the first element (other funvec types will have a symbol - identifying the type as the first object). */ -#define FUNVEC_COMPILED_P(funvec) \ - (FUNVEC_SIZE (funvec) > 0 && FUNVEC_COMPILED_TAG_P (AREF (funvec, 0))) - -/* Return non-zero if OBJ is byte-compile function. */ -#define COMPILEDP(obj) \ - (FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) - /* Flag bits in a character. These also get used in termhooks.h. Richard Stallman thinks that MULE (MUlti-Lingual Emacs) might need 22 bits for the character value @@ -1657,7 +1636,7 @@ typedef struct { #define WINDOWP(x) PSEUDOVECTORP (x, PVEC_WINDOW) #define TERMINALP(x) PSEUDOVECTORP (x, PVEC_TERMINAL) #define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR) -#define FUNVECP(x) PSEUDOVECTORP (x, PVEC_FUNVEC) +#define COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED) #define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER) #define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE) #define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE) @@ -1851,7 +1830,7 @@ typedef struct { #define FUNCTIONP(OBJ) \ ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ - || FUNVECP (OBJ) \ + || COMPILEDP (OBJ) \ || SUBRP (OBJ)) /* defsubr (Sname); @@ -2725,7 +2704,6 @@ EXFUN (Fmake_list, 2); extern Lisp_Object allocate_misc (void); EXFUN (Fmake_vector, 2); EXFUN (Fvector, MANY); -EXFUN (Ffunvec, MANY); EXFUN (Fmake_symbol, 1); EXFUN (Fmake_marker, 0); EXFUN (Fmake_string, 2); @@ -2745,7 +2723,6 @@ extern Lisp_Object make_pure_c_string (const char *data); extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_pure_vector (EMACS_INT); EXFUN (Fgarbage_collect, 0); -extern Lisp_Object make_funvec (Lisp_Object, int, int, Lisp_Object *); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_bool_vector, 2); extern Lisp_Object Qchar_table_extra_slots; diff --git a/src/lread.c b/src/lread.c index b30a75b67c3..77b397a03df 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2497,8 +2497,14 @@ read1 (register Lisp_Object readcharfun, int *pch, int first_in_list) invalid_syntax ("#&...", 5); } if (c == '[') - /* `function vector' objects, including byte-compiled functions. */ - return read_vector (readcharfun, 1); + { + /* Accept compiled functions at read-time so that we don't have to + build them using function calls. */ + Lisp_Object tmp; + tmp = read_vector (readcharfun, 1); + return Fmake_byte_code (XVECTOR (tmp)->size, + XVECTOR (tmp)->contents); + } if (c == '(') { Lisp_Object tmp; @@ -3311,7 +3317,7 @@ isfloat_string (const char *cp, int ignore_trailing) static Lisp_Object -read_vector (Lisp_Object readcharfun, int read_funvec) +read_vector (Lisp_Object readcharfun, int bytecodeflag) { register int i; register int size; @@ -3319,11 +3325,6 @@ read_vector (Lisp_Object readcharfun, int read_funvec) register Lisp_Object tem, item, vector; register struct Lisp_Cons *otem; Lisp_Object len; - /* If we're reading a funvec object we start out assuming it's also a - byte-code object (a subset of funvecs), so we can do any special - processing needed. If it's just an ordinary funvec object, we'll - realize that as soon as we've read the first element. */ - int read_bytecode = read_funvec; tem = read_list (1, readcharfun); len = Flength (tem); @@ -3335,18 +3336,11 @@ read_vector (Lisp_Object readcharfun, int read_funvec) { item = Fcar (tem); - /* If READ_BYTECODE is set, check whether this is really a byte-code - object, or just an ordinary `funvec' object -- non-byte-code - funvec objects use the same reader syntax. We can tell from the - first element which one it is. */ - if (read_bytecode && i == 0 && ! FUNVEC_COMPILED_TAG_P (item)) - read_bytecode = 0; /* Nope. */ - /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to Fread, to get the actual bytecode string and constants vector. */ - if (read_bytecode && load_force_doc_strings) + if (bytecodeflag && load_force_doc_strings) { if (i == COMPILED_BYTECODE) { @@ -3400,13 +3394,6 @@ read_vector (Lisp_Object readcharfun, int read_funvec) free_cons (otem); } - if (read_bytecode && size >= 4) - /* Convert this vector to a bytecode object. */ - vector = Fmake_byte_code (size, XVECTOR (vector)->contents); - else if (read_funvec && size >= 1) - /* Convert this vector to an ordinary funvec object. */ - XSETFUNVEC (vector, XVECTOR (vector)); - return vector; } diff --git a/src/print.c b/src/print.c index 11bce153ffc..00847d67318 100644 --- a/src/print.c +++ b/src/print.c @@ -1155,7 +1155,7 @@ print_preprocess (Lisp_Object obj) loop: if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -1337,7 +1337,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag /* Detect circularities and truncate them. */ if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -1960,7 +1960,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag else { EMACS_INT size = XVECTOR (obj)->size; - if (FUNVECP (obj)) + if (COMPILEDP (obj)) { PRINTCHAR ('#'); size &= PSEUDOVECTOR_SIZE_MASK; -- cgit v1.2.3 From a9de04fa62f123413d82b7b7b1e7a77705eb82dd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 26 Feb 2011 10:19:08 -0500 Subject: Compute freevars in cconv-analyse. * lisp/emacs-lisp/cconv.el: Compute freevars in cconv-analyse. (cconv-mutated, cconv-captured): Remove. (cconv-captured+mutated, cconv-lambda-candidates): Don't give them a global value. (cconv-freevars-alist): New var. (cconv-freevars): Remove. (cconv--lookup-let): Remove. (cconv-closure-convert-function): Extract from cconv-closure-convert-rec. (cconv-closure-convert-rec): Adjust to above changes. (fboundp): New function. (cconv-analyse-function, form): Rewrite. * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Handle declare-function here. (byte-compile-obsolete): Remove. (byte-compile-arglist-warn): Check late defsubst here. (byte-compile-file-form): Simplify. (byte-compile-file-form-defsubst): Remove. (byte-compile-macroexpand-declare-function): Rename from byte-compile-declare-function, turn it into a macro-expander. (byte-compile-normal-call): Check obsolescence. (byte-compile-quote-form): Remove. (byte-compile-defmacro): Revert to trunk's definition which seems to work just as well and handles `declare'. * lisp/emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile. * lisp/Makefile.in (BIG_STACK_DEPTH): Increase to 1200. (compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp". * lisp/emacs-lisp/macroexp.el: Use lexbind. (macroexpand-all-1): Check macro obsolescence. * lisp/vc/diff-mode.el: Use lexbind. * lisp/follow.el (follow-calc-win-end): Simplify. --- lisp/ChangeLog | 33 ++++ lisp/Makefile.in | 8 +- lisp/emacs-lisp/byte-run.el | 10 +- lisp/emacs-lisp/bytecomp.el | 123 +++++------- lisp/emacs-lisp/cconv.el | 468 +++++++++++++++++++------------------------- lisp/emacs-lisp/debug.el | 1 + lisp/emacs-lisp/macroexp.el | 11 +- lisp/follow.el | 3 +- lisp/vc/diff-mode.el | 4 +- src/bytecode.c | 2 +- 10 files changed, 309 insertions(+), 354 deletions(-) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ee6944d8e07..1b5e9400a8c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,36 @@ +2011-02-26 Stefan Monnier + + * emacs-lisp/cconv.el: Compute freevars in cconv-analyse. + (cconv-mutated, cconv-captured): Remove. + (cconv-captured+mutated, cconv-lambda-candidates): Don't give them + a global value. + (cconv-freevars-alist): New var. + (cconv-freevars): Remove. + (cconv--lookup-let): Remove. + (cconv-closure-convert-function): Extract from cconv-closure-convert-rec. + (cconv-closure-convert-rec): Adjust to above changes. + (fboundp): New function. + (cconv-analyse-function, form): Rewrite. + * emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): + Handle declare-function here. + (byte-compile-obsolete): Remove. + (byte-compile-arglist-warn): Check late defsubst here. + (byte-compile-file-form): Simplify. + (byte-compile-file-form-defsubst): Remove. + (byte-compile-macroexpand-declare-function): Rename from + byte-compile-declare-function, turn it into a macro-expander. + (byte-compile-normal-call): Check obsolescence. + (byte-compile-quote-form): Remove. + (byte-compile-defmacro): Revert to trunk's definition which seems to + work just as well and handles `declare'. + * emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile. + * Makefile.in (BIG_STACK_DEPTH): Increase to 1200. + (compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp". + * emacs-lisp/macroexp.el: Use lexbind. + (macroexpand-all-1): Check macro obsolescence. + * vc/diff-mode.el: Use lexbind. + * follow.el (follow-calc-win-end): Simplify. + 2011-02-25 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 389d5b154aa..0182b7f5072 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -74,7 +74,7 @@ AUTOGENEL = loaddefs.el \ # During bootstrapping the byte-compiler is run interpreted when compiling # itself, and uses more stack than usual. # -BIG_STACK_DEPTH = 1000 +BIG_STACK_DEPTH = 1200 BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" # Files to compile before others during a bootstrap. This is done to @@ -205,8 +205,8 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - $(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ - $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BIG_STACK_OPTS) -l bytecomp $(BYTE_COMPILE_EXTRA_FLAGS) \ + -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) # Files MUST be compiled one by one. If we compile several files in a @@ -222,7 +222,7 @@ compile-onefile: # cannot have prerequisites. .el.elc: @echo Compiling $< - $(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $< .PHONY: compile-first compile-main compile compile-always 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 6bc2b3b5617..4a53faefa3d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -424,6 +424,7 @@ 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 @@ -1140,13 +1141,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 @@ -1328,7 +1322,8 @@ 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)) @@ -1342,36 +1337,39 @@ extra args." (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.") @@ -1470,7 +1468,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) @@ -2198,9 +2196,8 @@ list that represents a doc string reference. ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) (let (bytecomp-handler) - (cond ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) + (cond ((and (consp form) + (symbolp (car form)) (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) (cond ((setq form (funcall bytecomp-handler form)) (byte-compile-flush-pending) @@ -2212,16 +2209,6 @@ list that represents a doc string reference. ;; 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 form) - ;; 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)) @@ -2914,7 +2901,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given BYTECOMP-BODY, compile it and return a new body. (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) - ;; FIXME: lexbind. Check all callers! (setq bytecomp-body (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) @@ -2922,20 +2908,18 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list bytecomp-body)))) -;; FIXME: Like defsubst's, this hunk-handler won't be called any more -;; because the macro is expanded away before we see it. -(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)) +;; 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 @@ -3005,6 +2989,8 @@ That command is designed for interactive use only" bytecomp-fn)) '(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)) @@ -3562,7 +3548,6 @@ discarding." (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))) @@ -3606,10 +3591,6 @@ discarding." (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 @@ -3845,6 +3826,7 @@ Return the offset in the form (VAR . OFFSET)." (byte-compile-push-constant nil))))) (defun byte-compile-not-lexical-var-p (var) + ;; FIXME: this doesn't catch defcustoms! (or (not (symbolp var)) (special-variable-p var) (memq var byte-compile-bound-variables) @@ -4097,15 +4079,16 @@ binding slots have been popped." (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - ;; FIXME handle decls, use defalias? - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-lambda (cdr (cdr form)) t)) - (for-effect nil)) - (byte-compile-push-constant (nth 1 form)) - (byte-compile-push-constant (cons 'macro code)) - (byte-compile-out 'byte-fset) - (byte-compile-discard)) - (byte-compile-constant (nth 1 form))) + (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)))) + `((defalias ',(nth 1 form) + ,(if (eq (car-safe code) 'make-byte-code) + `(cons 'macro ,code) + `'(macro . ,(eval code)))) + ,@decls + ',(nth 1 form))))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -4153,7 +4136,7 @@ binding slots have been popped." `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. - `(eval ',form))) ;FIXME: lexbind + `(eval ',form))) `',var)))) (defun byte-compile-autoload (form) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index bc7ecb1ad55..0e4b5d31699 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -82,110 +82,19 @@ (defconst cconv-liftwhen 3 "Try to do lambda lifting if the number of arguments + free variables is less than this number.") -(defvar cconv-mutated nil - "List of mutated variables in current form") -(defvar cconv-captured nil - "List of closure captured variables in current form") -(defvar cconv-captured+mutated nil - "An intersection between cconv-mutated and cconv-captured lists.") -(defvar cconv-lambda-candidates nil - "List of candidates for lambda lifting. -Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).") - -(defun cconv-freevars (form &optional fvrs) - "Find all free variables of given form. -Arguments: --- FORM is a piece of Elisp code after macroexpansion. --- FVRS(optional) is a list of variables already found. Used for recursive tree -traversal - -Returns a list of free variables." - ;; If a leaf in the tree is a symbol, but it is not a global variable, not a - ;; keyword, not 'nil or 't we consider this leaf as a variable. - ;; Free variables are the variables that are not declared above in this tree. - ;; For example free variables of (lambda (a1 a2 ..) body-forms) are - ;; free variables of body-forms excluding a1, a2 .. - ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are - ;; free variables of body-forms excluding v1, v2 ... - ;; and so on. - - ;; A list of free variables already found(FVRS) is passed in parameter - ;; to try to use cons or push where possible, and to minimize the usage - ;; of append. - - ;; This function can return duplicates (because we use 'append instead - ;; of union of two sets - for performance reasons). - (pcase form - (`(let ,varsvalues . ,body-forms) ; let special form - (let ((fvrs-1 '())) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm varsvalues) - (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1))) - (setq fvrs (nconc fvrs-1 fvrs)) - (dolist (exp varsvalues) - (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) - fvrs)) - - (`(let* ,varsvalues . ,body-forms) ; let* special form - (let ((vrs '()) - (fvrs-1 '())) - (dolist (exp varsvalues) - (if (consp exp) - (progn - (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (push (car exp) vrs)) - (progn - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (push exp vrs)))) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (append fvrs fvrs-1))) - - (`((lambda . ,_) . ,_) ; first element is lambda expression - (dolist (exp `((function ,(car form)) . ,(cdr form))) - (setq fvrs (cconv-freevars exp fvrs))) fvrs) +;; 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) - (`(cond . ,cond-forms) ; cond special form - (dolist (exp1 cond-forms) - (dolist (exp2 exp1) - (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) - - (`(quote . ,_) fvrs) ; quote form +;; 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) - (`(function . ((lambda ,vars . ,body-forms))) - (let ((functionform (cadr form)) (fvrs-1 '())) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) - (append fvrs fvrs-1))) ; function form - - (`(function . ,_) fvrs) ; same as quote - ;condition-case - (`(condition-case ,var ,protected-form . ,conditions-bodies) - (let ((fvrs-1 '())) - (dolist (exp conditions-bodies) - (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) - (setq fvrs-1 (delq var fvrs-1)) - (setq fvrs-1 (cconv-freevars protected-form fvrs-1)) - (append fvrs fvrs-1))) - - (`(,(and sym (or `defun `defconst `defvar)) . ,_) - ;; We call cconv-freevars only for functions(lambdas) - ;; defun, defconst, defvar are not allowed to be inside - ;; a function (lambda). - ;; (error "Invalid form: %s inside a function" sym) - (cconv-freevars `(progn ,@(cddr form)) fvrs)) - - (`(,_ . ,body-forms) ; First element is (like) a function. - (dolist (exp body-forms) - (setq fvrs (cconv-freevars exp fvrs))) fvrs) - - (_ (if (byte-compile-not-lexical-var-p form) - fvrs - (cons form fvrs))))) +;; Alist associating to each function body the list of its free variables. +(defvar cconv-freevars-alist) ;;;###autoload (defun cconv-closure-convert (form) @@ -195,16 +104,12 @@ Returns a list of free variables." Returns a form where all lambdas don't have any free variables." ;; (message "Entering cconv-closure-convert...") - (let ((cconv-mutated '()) + (let ((cconv-freevars-alist '()) (cconv-lambda-candidates '()) - (cconv-captured '()) (cconv-captured+mutated '())) ;; Analyse form - fill these variables with new information. - (cconv-analyse-form form '() 0) - ;; Calculate an intersection of cconv-mutated and cconv-captured. - (dolist (mvr cconv-mutated) - (when (memq mvr cconv-captured) ; - (push mvr cconv-captured+mutated))) + (cconv-analyse-form form '()) + (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) (cconv-closure-convert-rec form ; the tree '() ; @@ -213,15 +118,6 @@ Returns a form where all lambdas don't have any free variables." '() ))) -(defun cconv--lookup-let (table var binder form) - (let ((res nil)) - (dolist (elem table) - (when (and (eq (nth 2 elem) binder) - (eq (nth 3 elem) form)) - (assert (eq (car elem) var)) - (setq res elem))) - res)) - (defconst cconv--dummy-var (make-symbol "ignored")) (defun cconv--set-diff (s1 s2) @@ -261,6 +157,57 @@ Returns a form where all lambdas don't have any free variables." (unless (memq (car b) s) (push b res))) (nreverse res))) +(defun cconv-closure-convert-function (fvrs vars emvrs envs lmenvs body-forms + parentform) + (assert (equal body-forms (caar cconv-freevars-alist))) + (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. + (fv (cdr (pop cconv-freevars-alist))) + (body-forms-new '()) + (letbind '()) + (envector nil)) + (when fv + ;; Here we form our environment vector. + + (dolist (elm fv) + (push + (cconv-closure-convert-rec + ;; Remove `elm' from `emvrs' for this call because in case + ;; `elm' 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. + elm (remq elm emvrs) fvrs envs lmenvs) + envector)) ; Process vars for closure vector. + (setq envector (reverse envector)) + (setq envs fv) + (setq fvrs-new fv)) ; Update substitution list. + + (setq emvrs (cconv--set-diff emvrs vars)) + (setq lmenvs (cconv--map-diff-set lmenvs vars)) + + ;; The difference between envs and fvrs is explained + ;; in comment in the beginning of the function. + (dolist (var vars) + (when (member (cons (list var) parentform) cconv-captured+mutated) + (push var emvrs) + (push `(,var (list ,var)) letbind))) + (dolist (elm body-forms) ; convert function body + (push (cconv-closure-convert-rec + elm emvrs fvrs-new envs lmenvs) + body-forms-new)) + + (setq body-forms-new + (if letbind `((let ,letbind . ,(reverse body-forms-new))) + (reverse body-forms-new))) + + (cond + ;if no freevars - do nothing + ((null envector) + `(function (lambda ,vars . ,body-forms-new))) + ; 1 free variable - do not build vector + (t + `(internal-make-closure + ,vars ,envector . ,body-forms-new))))) + (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) ;; This function actually rewrites the tree. "Eliminates all free variables of all lambdas in given forms. @@ -303,15 +250,18 @@ Returns a form where all lambdas don't have any free variables." (dolist (binder binders) (let* ((value nil) (var (if (not (consp binder)) - 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. - ((cconv--lookup-let cconv-lambda-candidates var binder form) - - (let* ((fv (delete-dups (cconv-freevars value '()))) + ((member (cons binder form) cconv-lambda-candidates) + (assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + (let* ((fv (cdr (pop cconv-freevars-alist))) (funargs (cadr (cadr value))) (funcvars (append fv funargs)) (funcbodies (cddadr value)) ; function bodies @@ -338,7 +288,7 @@ Returns a form where all lambdas don't have any free variables." ,(reverse funcbodies-new)))))))) ;; Check if it needs to be turned into a "ref-cell". - ((cconv--lookup-let cconv-captured+mutated var binder form) + ((member (cons binder form) cconv-captured+mutated) ;; Declared variable is mutated and captured. (prog1 `(list ,(cconv-closure-convert-rec @@ -404,13 +354,12 @@ Returns a form where all lambdas don't have any free variables." )) ; end of dolist over binders (when (eq letsym 'let) - (let (var fvrs-1 emvrs-1 lmenvs-1) - ;; Here we update emvrs, fvrs and lmenvs lists - (setq fvrs (cconv--set-diff-map fvrs binders-new)) - (setq emvrs (cconv--set-diff-map emvrs binders-new)) - (setq emvrs (append emvrs emvrs-new)) - (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) - (setq lmenvs (append lmenvs lmenvs-new))) + ;; Here we update emvrs, fvrs and lmenvs lists + (setq fvrs (cconv--set-diff-map fvrs binders-new)) + (setq emvrs (cconv--set-diff-map emvrs binders-new)) + (setq emvrs (append emvrs emvrs-new)) + (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) + (setq lmenvs (append lmenvs lmenvs-new)) ;; Here we do the same letbinding as for let* above ;; to avoid situation when a free variable of a lambda lifted @@ -478,56 +427,8 @@ Returns a form where all lambdas don't have any free variables." (`(quote . ,_) form) (`(function (lambda ,vars . ,body-forms)) ; function form - (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. - (fv (delete-dups (cconv-freevars form '()))) - (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. - (body-forms-new '()) - (letbind '()) - (mv nil) - (envector nil)) - (when fv - ;; Here we form our environment vector. - - (dolist (elm fv) - (push - (cconv-closure-convert-rec - ;; Remove `elm' from `emvrs' for this call because in case - ;; `elm' 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. - elm (remq elm emvrs) fvrs envs lmenvs) - envector)) ; Process vars for closure vector. - (setq envector (reverse envector)) - (setq envs fv) - (setq fvrs-new fv)) ; Update substitution list. - - (setq emvrs (cconv--set-diff emvrs vars)) - (setq lmenvs (cconv--map-diff-set lmenvs vars)) - - ;; The difference between envs and fvrs is explained - ;; in comment in the beginning of the function. - (dolist (elm cconv-captured+mutated) ; Find mutated arguments - (setq mv (car elm)) ; used in inner closures. - (when (and (memq mv vars) (eq form (caddr elm))) - (progn (push mv emvrs) - (push `(,mv (list ,mv)) letbind)))) - (dolist (elm body-forms) ; convert function body - (push (cconv-closure-convert-rec - elm emvrs fvrs-new envs lmenvs) - body-forms-new)) - - (setq body-forms-new - (if letbind `((let ,letbind . ,(reverse body-forms-new))) - (reverse body-forms-new))) - - (cond - ;if no freevars - do nothing - ((null envector) - `(function (lambda ,vars . ,body-forms-new))) - ; 1 free variable - do not build vector - (t - `(internal-make-closure - ,vars ,envector . ,body-forms-new))))) + (cconv-closure-convert-function + fvrs vars emvrs envs lmenvs body-forms form)) (`(internal-make-closure . ,_) (error "Internal byte-compiler error: cconv called twice")) @@ -548,21 +449,21 @@ Returns a form where all lambdas don't have any free variables." ;defun, defmacro (`(,(and sym (or `defun `defmacro)) ,func ,vars . ,body-forms) + + ;; The freevar data was pushed onto cconv-freevars-alist + ;; but we don't need it. + (assert (equal body-forms (caar cconv-freevars-alist))) + (assert (null (cdar cconv-freevars-alist))) + (setq cconv-freevars-alist (cdr cconv-freevars-alist)) + (let ((body-new '()) ; The whole body. (body-forms-new '()) ; Body w\o docstring and interactive. (letbind '())) ; Find mutable arguments. (dolist (elm vars) - (let ((lmutated cconv-captured+mutated) - (ismutated nil)) - (while (and lmutated (not ismutated)) - (when (and (eq (caar lmutated) elm) - (eq (caddar lmutated) form)) - (setq ismutated t)) - (setq lmutated (cdr lmutated))) - (when ismutated - (push elm letbind) - (push elm emvrs)))) + (when (member (cons (list elm) form) cconv-captured+mutated) + (push elm letbind) + (push elm emvrs))) ;Transform body-forms. (when (stringp (car body-forms)) ; Treat docstring well. (push (car body-forms) body-new) @@ -629,12 +530,13 @@ Returns a form where all lambdas don't have any free variables." (setq value (cconv-closure-convert-rec (cadr forms) emvrs fvrs envs lmenvs)) - (if (memq sym emvrs) - (push `(setcar ,sym-new ,value) prognlist) - (if (symbolp sym-new) - (push `(setq ,sym-new ,value) prognlist) - (debug) ;FIXME: When can this be right? - (push `(set ,sym-new ,value) prognlist))) + (cond + ((memq sym emvrs) (push `(setcar ,sym-new ,value) prognlist)) + ((symbolp sym-new) (push `(setq ,sym-new ,value) prognlist)) + ;; 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. + (t (push value prognlist))) (setq forms (cddr forms))) (if (cdr prognlist) `(progn . ,(reverse prognlist)) @@ -697,54 +599,110 @@ Returns a form where all lambdas don't have any free variables." `(car ,form) ; replace form => (car form) form)))))) -(defun cconv-analyse-function (args body env parentform inclosure) - (dolist (arg args) - (cond - ((byte-compile-not-lexical-var-p arg) - (byte-compile-report-error - (format "Argument %S is not a lexical variable" arg))) - ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... - (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars. - (dolist (form body) ;Analyse body forms. - (cconv-analyse-form form env inclosure))) - -(defun cconv-analyse-form (form env inclosure) - "Find mutated variables and variables captured by closure. Analyse -lambdas if they are suitable for lambda lifting. +(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) + ;; use = `(,binder ,read ,mutated ,captured ,called) + (pcase vardata + (`(,binder nil ,_ ,_ nil) + ;; FIXME: Don't warn about unused fun-args. + ;; FIXME: Don't warn about uninterned vars or _ vars. + ;; FIXME: This gives warnings in the wrong order and with wrong line + ;; number and without function name info. + (byte-compile-log-warning (format "Unused variable %S" (car binder)))) + ;; If it's unused, there's no point converting it into a cons-cell, even if + ;; it's captures and mutated. + (`(,binder ,_ t t ,_) + (push (cons binder form) cconv-captured+mutated)) + (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) + ;; This is very rare in typical Elisp code. It's probably not really + ;; worth the trouble to try and use lambda-lifting in Elisp, but + ;; since we coded it up, we might as well use it. + (push (cons binder form) cconv-lambda-candidates)) + (`(,_ ,_ ,_ ,_ ,_) nil) + (dontcare))) + +(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-report-error + (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)) + ;; 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 a list of variables visible in current lexical environment. - Each entry has the form (VAR INCLOSURE BINDER PARENTFORM) - for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments. --- INCLOSURE is the nesting level within lambdas." +-- 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) - inclosure)) + (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) - (let ((varstruct (list var inclosure binder form))) - (push varstruct env) ; Push a new one. + (let ((varstruct (list var nil nil nil nil))) + (push (cons binder (cdr varstruct)) newvars) + (push varstruct env)))) - (pcase value - (`(function (lambda . ,_)) - ;; If var is a function push it to lambda list. - (push varstruct cconv-lambda-candidates))))))) + (dolist (form body-forms) ; Analyse body forms. + (cconv-analyse-form form env)) - (dolist (form body-forms) ; Analyse body forms. - (cconv-analyse-form form env inclosure))) + (dolist (vardata newvars) + (cconv-analyse-use vardata form)))) ; defun special form (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) @@ -753,33 +711,28 @@ lambdas if they are suitable for lambda lifting. (format "Function %S will ignore its context %S" func (mapcar #'car env)) t :warning)) - (cconv-analyse-function vrs body-forms nil form 0)) + (cconv-analyse-function vrs body-forms nil form)) (`(function (lambda ,vrs . ,body-forms)) - (cconv-analyse-function vrs body-forms env form (1+ inclosure))) + (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 - (push v cconv-mutated) - ;; Delete from candidate list for lambda lifting. - (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) - (unless (eq inclosure (cadr v)) ;Bound in a different closure level. - (push v cconv-captured)))) - (cconv-analyse-form (cadr forms) env inclosure) + (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 inclosure))) + (cconv-analyse-form exp env))) (`(cond . ,cond-forms) ; cond special form (dolist (forms cond-forms) (dolist (form forms) - (cconv-analyse-form form env inclosure)))) + (cconv-analyse-form form env)))) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote @@ -788,63 +741,44 @@ lambdas if they are suitable for lambda lifting. ;; FIXME: The bytecode for condition-case forces us to wrap the ;; form and handlers in closures (for handlers, it's probably ;; unavoidable, but not for the protected form). - (setq inclosure (1+ inclosure)) - (cconv-analyse-form protected-form env inclosure) - (push (list var inclosure form) env) + (cconv-analyse-function () (list protected-form) env form) (dolist (handler handlers) - (dolist (form (cdr handler)) - (cconv-analyse-form form env inclosure)))) + (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 inclosure) - (setq inclosure (1+ inclosure)) - (dolist (form body) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-form form env) + (cconv-analyse-function () body env form)) ;; FIXME: The bytecode for save-window-excursion and the lack of ;; bytecode for track-mouse forces us to wrap the body. (`(track-mouse . ,body) - (setq inclosure (1+ inclosure)) - (dolist (form body) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-function () body env form)) (`(,(or `defconst `defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) - (cconv-analyse-form value env inclosure)) + (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. - (if (symbolp fun) - (let ((lv (assq fun cconv-lambda-candidates))) - (when lv - (unless (eq (cadr lv) inclosure) - (push lv cconv-captured) - ;; If this funcall and the definition of fun are in - ;; different closures - we delete fun from candidate - ;; list, because it is too complicated to manage free - ;; variables in this case. - (setq cconv-lambda-candidates - (delq lv cconv-lambda-candidates))))) - (cconv-analyse-form fun env inclosure)) + (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 inclosure))) + (cconv-analyse-form form env))) (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-form form env))) ((pred symbolp) (let ((dv (assq form env))) ; dv = declared and visible (when dv - (unless (eq inclosure (cadr dv)) ; capturing condition - (push dv cconv-captured)) - ;; Delete lambda if it is found here, since it escapes. - (setq cconv-lambda-candidates - (delq dv cconv-lambda-candidates))))))) + (setf (nth 1 dv) t)))))) (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0b2ea81fb64..0bdab919434 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -269,6 +269,7 @@ That buffer should be current already." (setq buffer-undo-list t) (let ((standard-output (current-buffer)) (print-escape-newlines t) + (print-quoted t) ;Doesn't seem to work :-( (print-level 1000) ;8 ;; (print-length 50) ) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 781195d034a..4377797cba8 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. ;; @@ -108,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)) diff --git a/lisp/follow.el b/lisp/follow.el index 7e6d4e7ee35..7f4093dd442 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)" ;; XEmacs can calculate the end of the window by using ;; the 'guarantee options. GOOD! (let ((end (window-end win t))) - (if (= end (funcall (symbol-function 'point-max) - (window-buffer win))) + (if (= end (point-max (window-buffer win))) (list end t) (list (+ end 1) nil))) ;; Emacs: We have to calculate the end by ourselves. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 13d10f02b41..59e442a89c3 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1,4 +1,4 @@ -;;; diff-mode.el --- a mode for viewing/editing context diffs +;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*- ;; Copyright (C) 1998-2011 Free Software Foundation, Inc. @@ -1278,7 +1278,7 @@ a diff with \\[diff-reverse-direction]. (add-hook 'after-change-functions 'diff-after-change-function nil t) (add-hook 'post-command-hook 'diff-post-command-hook nil t)) ;; Neat trick from Dave Love to add more bindings in read-only mode: - (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) + (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) (add-to-list 'minor-mode-overriding-map-alist ro-bind) ;; Turn off this little trick in case the buffer is put in view-mode. (add-hook 'view-mode-hook diff --git a/src/bytecode.c b/src/bytecode.c index 464bc3d12de..9693a5a9196 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE */ +#define BYTE_CODE_SAFE 1 /* #define BYTE_CODE_METER */ -- cgit v1.2.3 From e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 5 Mar 2011 23:48:17 -0500 Subject: Fix pcase memoizing; change lexbound byte-code marker. * src/bytecode.c (exec_byte_code): Remove old lexical binding slot handling and replace it with the a integer args-desc handling. * eval.c (funcall_lambda): Adjust arglist test accordingly. * lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-signature): Handle integer arglist descriptor. (byte-compile-make-args-desc): Make integer arglist descriptor. (byte-compile-lambda): Use integer arglist descriptor to mark lexical byte-coded functions instead of an extra slot. * lisp/help-fns.el (help-add-fundoc-usage): Don't add a dummy doc. (help-split-fundoc): Return a nil doc if there was no actual doc. (help-function-arglist): Generate an arglist from an integer arg-desc. * lisp/emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize; Make only the key weak. (pcase): Change the key used in the memoization table, so it does not always get GC'd away. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the pcase pattern to generate slightly better code. --- lisp/ChangeLog | 17 +++++++++ lisp/emacs-lisp/byte-opt.el | 3 +- lisp/emacs-lisp/bytecomp.el | 87 +++++++++++++++++++++++++++++++-------------- lisp/emacs-lisp/cconv.el | 11 +++--- lisp/emacs-lisp/macroexp.el | 9 ++--- lisp/emacs-lisp/pcase.el | 23 +++++++++--- lisp/help-fns.el | 26 ++++++++++++-- src/ChangeLog | 6 ++++ src/alloc.c | 13 +++++-- src/bytecode.c | 71 +++++++++++++++++++++--------------- 10 files changed, 188 insertions(+), 78 deletions(-) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 10f57c2b96a..70604238117 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,20 @@ +2011-03-06 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-arglist-signature): + Handle integer arglist descriptor. + (byte-compile-make-args-desc): Make integer arglist descriptor. + (byte-compile-lambda): Use integer arglist descriptor to mark lexical + byte-coded functions instead of an extra slot. + * help-fns.el (help-add-fundoc-usage): Don't add a dummy doc. + (help-split-fundoc): Return a nil doc if there was no actual doc. + (help-function-arglist): Generate an arglist from an integer arg-desc. + * emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize; + Make only the key weak. + (pcase): Change the key used in the memoization table, so it does not + always get GC'd away. + * emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the + pcase pattern to generate slightly better code. + 2011-03-01 Stefan Monnier * emacs-lisp/cconv.el (cconv-liftwhen): Increase threshold. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d86cb729081..6d6eb68535e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2009,8 +2009,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3575b10e1f1..297655a235a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -33,6 +33,9 @@ ;;; Code: +;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-" +;; variable prefix. + ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, @@ -1180,22 +1183,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) @@ -2645,6 +2654,26 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; 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. @@ -2716,18 +2745,22 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; 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 - lexical-binding) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if (or bytecomp-int lexical-binding) - (list (nth 1 bytecomp-int))) - (if lexical-binding - '(t)))) + (if lexical-binding + (byte-compile-make-args-desc bytecomp-arglist) + bytecomp-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 + bytecomp-doc bytecomp-arglist))) + ((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)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7855193fa3f..5501c13ee4f 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -66,22 +66,21 @@ ;;; Code: ;; TODO: +;; - byte-optimize-form should be applied before cconv. +;; - maybe unify byte-optimize and compiler-macros. ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. -;; - Change new byte-code representation, so it directly gives the -;; number of mandatory and optional arguments as well as whether or -;; not there's a &rest arg. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. ;; - new byte codes for unwind-protect, catch, and condition-case so that ;; closures aren't needed at all. ;; - 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 +;; 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 bytecompiler. +;; - add tail-calls to bytecode.c and the byte compiler. ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 4377797cba8..168a430577d 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -176,10 +176,11 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand-all-forms args))))) ;; Macro expand compiler macros. ;; FIXME: Don't depend on CL. - (`(,(and (pred symbolp) fun - (guard (and (eq (get fun 'byte-compile) - 'cl-byte-compile-compiler-macro) - (functionp 'compiler-macroexpand)))) + (`(,(pred (lambda (fun) + (and (symbolp fun) + (eq (get fun 'byte-compile) + 'cl-byte-compile-compiler-macro) + (functionp 'compiler-macroexpand)))) . ,_) (let ((newform (compiler-macroexpand form))) (if (eq form newform) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 89bbff980c4..2300ebf721a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -42,7 +42,7 @@ ;; 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)) @@ -78,10 +78,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) @@ -135,6 +146,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))))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 87fb6a02bd3..58df45bc33c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING." ;; Replace `fn' with the actual function name. (if (consp def) "anonymous" def) (match-string 1 docstring)) - (substring docstring 0 (match-beginning 0))))) + (unless (zerop (match-beginning 0)) + (substring docstring 0 (match-beginning 0)))))) +;; FIXME: Move to subr.el? (defun help-add-fundoc-usage (docstring arglist) "Add the usage info to DOCSTRING. If DOCSTRING already has a usage info, then just return it unchanged. The usage info is built from ARGLIST. DOCSTRING can be nil. ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." - (unless (stringp docstring) (setq docstring "Not documented")) - (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t)) + (unless (stringp docstring) (setq docstring "")) + (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) + (eq arglist t)) docstring (concat docstring (if (string-match "\n?\n\\'" docstring) @@ -95,6 +98,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (concat "(fn" (match-string 1 arglist) ")") (format "%S" (help-make-usage 'fn arglist)))))) +;; FIXME: Move to subr.el? (defun help-function-arglist (def) ;; Handle symbols aliased to other symbols. (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) @@ -103,12 +107,28 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." ;; and do the same for interpreted closures (if (eq (car-safe def) 'closure) (setq def (cddr def))) (cond + ((and (byte-code-function-p def) (integerp (aref def 0))) + (let* ((args-desc (aref def 0)) + (max (lsh args-desc -8)) + (min (logand args-desc 127)) + (rest (logand args-desc 128)) + (arglist ())) + (dotimes (i min) + (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) + (when (> max min) + (push '&optional arglist) + (dotimes (i (- max min)) + (push (intern (concat "arg" (number-to-string (+ 1 i min)))) + arglist))) + (unless (zerop rest) (push '&rest arglist) (push 'rest arglist)) + (nreverse arglist))) ((byte-code-function-p def) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) "[Arg list not available until function definition is loaded.]") (t t))) +;; FIXME: Move to subr.el? (defun help-make-usage (function arglist) (cons (if (symbolp function) function 'anonymous) (mapcar (lambda (arg) diff --git a/src/ChangeLog b/src/ChangeLog index c638e1fa4b5..e8b3c57fbd0 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2011-03-06 Stefan Monnier + + * bytecode.c (exec_byte_code): Remove old lexical binding slot handling + and replace it with the a integer args-desc handling. + * eval.c (funcall_lambda): Adjust arglist test accordingly. + 2011-03-01 Stefan Monnier * callint.c (quotify_arg): Simplify the logic. diff --git a/src/alloc.c b/src/alloc.c index 0b7db7ec627..c7fd8747f74 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2945,10 +2945,19 @@ usage: (vector &rest OBJECTS) */) DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. -The arguments should be the arglist, bytecode-string, constant vector, -stack size, (optional) doc string, and (optional) interactive spec. +The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant +vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING, +and (optional) INTERACTIVE-SPEC. The first four arguments are required; at most six have any significance. +The ARGLIST can be either like the one of `lambda', in which case the arguments +will be dynamically bound before executing the byte code, or it can be an +integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the +minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number +of arguments (ignoring &rest) and the R bit specifies whether there is a &rest +argument to catch the left-over arguments. If such an integer is used, the +arguments will not be dynamically bound but will be instead pushed on the +stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (register int nargs, Lisp_Object *args) { diff --git a/src/bytecode.c b/src/bytecode.c index 9693a5a9196..dbab02886e2 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -502,37 +502,50 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif - if (! NILP (args_template)) - /* We should push some arguments on the stack. */ + if (INTEGERP (args_template)) { - Lisp_Object at; - int pushed = 0, optional = 0; - - for (at = args_template; CONSP (at); at = XCDR (at)) - if (EQ (XCAR (at), Qand_optional)) - optional = 1; - else if (EQ (XCAR (at), Qand_rest)) - { - PUSH (pushed < nargs - ? Flist (nargs - pushed, args) - : Qnil); - pushed = nargs; - at = Qnil; - break; - } - else if (pushed < nargs) - { - PUSH (*args++); - pushed++; - } - else if (optional) - PUSH (Qnil); - else - break; - - if (pushed != nargs || !NILP (at)) + int at = XINT (args_template); + int rest = at & 128; + int mandatory = at & 127; + int nonrest = at >> 8; + eassert (mandatory <= nonrest); + if (nargs <= nonrest) + { + int i; + for (i = 0 ; i < nargs; i++, args++) + PUSH (*args); + if (nargs < mandatory) + /* Too few arguments. */ + Fsignal (Qwrong_number_of_arguments, + Fcons (Fcons (make_number (mandatory), + rest ? Qand_rest : make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + else + { + for (; i < nonrest; i++) + PUSH (Qnil); + if (rest) + PUSH (Qnil); + } + } + else if (rest) + { + int i; + for (i = 0 ; i < nonrest; i++, args++) + PUSH (*args); + PUSH (Flist (nargs - nonrest, args)); + } + else + /* Too many arguments. */ Fsignal (Qwrong_number_of_arguments, - Fcons (args_template, Fcons (make_number (nargs), Qnil))); + Fcons (Fcons (make_number (mandatory), + make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + } + else if (! NILP (args_template)) + /* We should push some arguments on the stack. */ + { + error ("Unknown args template!"); } while (1) -- cgit v1.2.3 From ba83908c4b7fda12991ae9073028a60da87c1fa2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 11 Mar 2011 15:04:22 -0500 Subject: Misc fixes, and use lexical-binding in more files. * lisp/subr.el (letrec): New macro. (with-wrapper-hook): Move from lisp/simple.el and don't use CL. * simple.el (with-wrapper-hook): Move with-wrapper-hook to subr.el. * lisp/help-fns.el (help-function-arglist): Handle subroutines as well. (describe-variable): Use special-variable-p to filter completions. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Don't expand `declare' in defmacros. * lisp/emacs-lisp/cconv.el (cconv-convert, cconv-analyse-form): Handle `declare'. * lisp/emacs-lisp/cl.el (pushnew): Silence unfixable warning. * lisp/emacs-lisp/cl-macs.el (defstruct, define-compiler-macro): Mark unused arg as unused. * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Use memq. * lisp/emacs-lisp/autoload.el (make-autoload): Don't assume the macro's first sexp is a list. (autoload-generate-file-autoloads): Improve error message. * lisp/emacs-lisp/advice.el (ad-arglist): Use help-function-arglist to understand the new byte-code arg format. * lisp/vc/smerge-mode.el: * lisp/vc/log-view.el: * lisp/vc/log-edit.el: * lisp/vc/cvs-status.el: * lisp/uniquify.el: * lisp/textmodes/css-mode.el: * lisp/textmodes/bibtex-style.el: * lisp/reveal.el: * lisp/newcomment.el: * lisp/emacs-lisp/smie.el: * lisp/abbrev.el: Use lexical-binding. * src/eval.c (Fprog1, Fprog2): Simplify and use XCDR/XCAR. (Fdefvar): Remove redundant SYMBOLP check. (Ffunctionp): Don't signal an error for undefined aliases. * doc/lispref/variables.texi (Converting to Lexical Binding): New node. --- doc/lispref/ChangeLog | 4 +++ doc/lispref/variables.texi | 40 ++++++++++++++++++++++++++- etc/NEWS.lexbind | 3 ++- lisp/ChangeLog | 32 ++++++++++++++++++++++ lisp/abbrev.el | 29 ++++++++++---------- lisp/emacs-lisp/advice.el | 16 ++++------- lisp/emacs-lisp/autoload.el | 5 ++-- lisp/emacs-lisp/byte-opt.el | 11 ++++---- lisp/emacs-lisp/bytecomp.el | 34 ++++++++++++----------- lisp/emacs-lisp/cconv.el | 4 +++ lisp/emacs-lisp/cl-loaddefs.el | 17 +++++++----- lisp/emacs-lisp/cl-macs.el | 14 +++++----- lisp/emacs-lisp/cl.el | 9 ++++++- lisp/emacs-lisp/macroexp.el | 11 +++++++- lisp/emacs-lisp/smie.el | 4 +-- lisp/help-fns.el | 22 ++++++++++++--- lisp/mpc.el | 4 +-- lisp/newcomment.el | 4 +-- lisp/reveal.el | 2 +- lisp/simple.el | 45 ------------------------------- lisp/subr.el | 61 ++++++++++++++++++++++++++++++++++++++++++ lisp/textmodes/bibtex-style.el | 4 +-- lisp/textmodes/css-mode.el | 2 +- lisp/uniquify.el | 2 +- lisp/vc/cvs-status.el | 46 +++++++++++++++++-------------- lisp/vc/diff-mode.el | 53 ++++++++++++++++++------------------ lisp/vc/log-edit.el | 6 ++--- lisp/vc/log-view.el | 3 ++- lisp/vc/smerge-mode.el | 2 +- src/ChangeLog | 6 +++++ src/eval.c | 25 ++++++++--------- 31 files changed, 329 insertions(+), 191 deletions(-) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index ab993fe35a2..8a1ccef335f 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,7 @@ +2011-03-11 Stefan Monnier + + * variables.texi (Converting to Lexical Binding): New node. + 2011-03-01 Stefan Monnier * variables.texi (Scope): Mention the availability of lexical scoping. diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 27ec4831cbe..fad76ed39f8 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -912,7 +912,7 @@ dynamically scoped, like all variables in Emacs Lisp. * Extent:: Extent means how long in time a value exists. * Impl of Scope:: Two ways to implement dynamic scoping. * Using Scoping:: How to use dynamic scoping carefully and avoid problems. -* Lexical Binding:: +* Lexical Binding:: Use of lexical scoping. @end menu @node Scope @@ -1136,6 +1136,44 @@ body can later be evaluated in the proper context. Those objects are called by @code{funcall}, and they are represented by a cons cell whose @code{car} is the symbol @code{closure}. +@menu +* Converting to Lexical Binding:: How to start using lexical scoping +@end menu + +@node Converting to Lexical Binding +@subsubsection Converting a package to use lexical scoping + +Lexical scoping, as currently implemented, does not bring many significant +benefits, unless you are a seasoned functional programmer addicted to +higher-order functions. But its importance will increase in the future: +lexical scoping opens up a lot more opportunities for optimization, so +lexically scoped code is likely to run faster in future Emacs versions, and it +is much more friendly to concurrency, which we want to add in the near future. + +Converting a package to lexical binding is usually pretty easy and should not +break backward compatibility: just add a file-local variable setting +@code{lexical-binding} to @code{t} and add declarations of the form +@code{(defvar @var{VAR})} for every variable which still needs to use +dynamic scoping. + +To find which variables need this declaration, the simplest solution is to +check the byte-compiler's warnings. The byte-compiler will usually find those +variables either because they are used outside of a let-binding (leading to +warnings about reference or assignment to ``free variable @var{VAR}'') or +because they are let-bound but not used within the let-binding (leading to +warnings about ``unused lexical variable @var{VAR}''). + +In cases where a dynamically scoped variable was bound as a function argument, +you will also need to move this binding to a @code{let}. These cases are also +flagged by the byte-compiler. + +To silence byte-compiler warnings about unused variables, just use a variable +name that start with an underscore, which the byte-compiler interpret as an +indication that this is a variable known not to be used. + +In most cases, the resulting code will then work with either setting of +@code{lexical-binding}, so it can still be used with older Emacsen (which will +simply ignore the @code{lexical-binding} variable setting). @node Buffer-Local Variables @section Buffer-Local Variables diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind index bcb56c313f8..de5d9a07715 100644 --- a/etc/NEWS.lexbind +++ b/etc/NEWS.lexbind @@ -18,7 +18,8 @@ all the code in that file. ** Lexically scoped interpreted functions are represented with a new form of function value which looks like (closure ENV lambda ARGS &rest BODY). - +** New macro `letrec' to define recursive local functions. + ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fd00cf70f40..0b432eb46d9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,35 @@ +2011-03-11 Stefan Monnier + + * subr.el (letrec): New macro. + (with-wrapper-hook): Move from simple.el and don't use CL. + * simple.el (with-wrapper-hook): Move with-wrapper-hook to subr.el. + * help-fns.el (help-function-arglist): Handle subroutines as well. + (describe-variable): Use special-variable-p to filter completions. + * emacs-lisp/macroexp.el (macroexpand-all-1): Don't expand `declare' + in defmacros. + * emacs-lisp/cconv.el (cconv-convert, cconv-analyse-form): + Handle `declare'. + * emacs-lisp/cl.el (pushnew): Silence unfixable warning. + * emacs-lisp/cl-macs.el (defstruct, define-compiler-macro): + Mark unused arg as unused. + * emacs-lisp/byte-opt.el (byte-optimize-lapcode): Use memq. + * emacs-lisp/autoload.el (make-autoload): Don't assume the macro's + first sexp is a list. + (autoload-generate-file-autoloads): Improve error message. + * emacs-lisp/advice.el (ad-arglist): Use help-function-arglist + to understand the new byte-code arg format. + * vc/smerge-mode.el: + * vc/log-view.el: + * vc/log-edit.el: + * vc/cvs-status.el: + * uniquify.el: + * textmodes/css-mode.el: + * textmodes/bibtex-style.el: + * reveal.el: + * newcomment.el: + * emacs-lisp/smie.el: + * abbrev.el: Use lexical-binding. + 2011-03-10 Stefan Monnier * emacs-lisp/bytecomp.el: Use lexical-binding. diff --git a/lisp/abbrev.el b/lisp/abbrev.el index fbca214a649..3844391a180 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -1,4 +1,4 @@ -;;; abbrev.el --- abbrev mode commands for Emacs +;;; abbrev.el --- abbrev mode commands for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc. @@ -767,20 +767,19 @@ Returns the abbrev symbol, if expansion took place." (destructuring-bind (&optional sym name wordstart wordend) (abbrev--before-point) (when sym - (let ((value sym)) - (unless (or ;; executing-kbd-macro - noninteractive - (window-minibuffer-p (selected-window))) - ;; Add an undo boundary, in case we are doing this for - ;; a self-inserting command which has avoided making one so far. - (undo-boundary)) - ;; Now sym is the abbrev symbol. - (setq last-abbrev-text name) - (setq last-abbrev sym) - (setq last-abbrev-location wordstart) - ;; If this abbrev has an expansion, delete the abbrev - ;; and insert the expansion. - (abbrev-insert sym name wordstart wordend)))))) + (unless (or ;; executing-kbd-macro + noninteractive + (window-minibuffer-p (selected-window))) + ;; Add an undo boundary, in case we are doing this for + ;; a self-inserting command which has avoided making one so far. + (undo-boundary)) + ;; Now sym is the abbrev symbol. + (setq last-abbrev-text name) + (setq last-abbrev sym) + (setq last-abbrev-location wordstart) + ;; If this abbrev has an expansion, delete the abbrev + ;; and insert the expansion. + (abbrev-insert sym name wordstart wordend))))) (defun unexpand-abbrev () "Undo the expansion of the last abbrev that expanded. 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 "^#]+\\)>$" 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 68ec2144dae..a4254bfeca1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1657,8 +1657,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 @@ -1677,8 +1676,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)) @@ -1701,8 +1700,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; only be known when the closure will be built at ;; run-time). (consp (cdr lap0))) - (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) + (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" diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 77dd3408219..c661e6bea7a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -432,11 +432,12 @@ This list lives partly on the stack.") (eval-when-compile . (lambda (&rest body) (list 'quote + ;; FIXME: is that right in lexbind code? (byte-compile-eval - (byte-compile-top-level - (macroexpand-all - (cons 'progn body) - byte-compile-initial-macro-environment)))))) + (byte-compile-top-level + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -2732,16 +2733,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let* ((compiled - (byte-compile-top-level (cons 'progn bytecomp-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 - bytecomp-fun)) - reserved-csts))) + (let ((compiled + (byte-compile-top-level (cons 'progn bytecomp-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 + bytecomp-fun)) + reserved-csts))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) (apply 'make-byte-code @@ -3027,8 +3028,9 @@ That command is designed for interactive use only" bytecomp-fn)) (when (and (byte-compile-warning-enabled-p 'callargs) (symbolp (car form))) (if (memq (car form) - '(custom-declare-group custom-declare-variable - custom-declare-face)) + '(custom-declare-group + ;; custom-declare-variable custom-declare-face + )) (byte-compile-nogroup-warn form)) (when (get (car form) 'byte-obsolete-info) (byte-compile-warn-obsolete (car form))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 741bc7ce74f..5be84c15d89 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -488,6 +488,8 @@ places where they originally did not directly appear." (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 @@ -683,6 +685,8 @@ and updates the data stored in ENV." ;; 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))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 17046f1ffb4..2795b143e47 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -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" "5bdba3fbbcbfcf57a2c9ca87a6318150") +;;;;;; 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" "864a28dc0495ad87d39637a965387526") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -535,6 +535,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn &rest BODY)" nil (quote macro)) +(autoload 'the "cl-macs" "\ + + +\(fn TYPE FORM)" nil (quote macro)) + (autoload 'declare "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8b1fc9d5f53..851355e2c75 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2428,11 +2428,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) @@ -2586,7 +2588,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) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 1d2b82f82eb..d303dab4ad3 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))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168a430577d..55ca90597d1 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -131,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 . ,_))) 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 ...) 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 ()) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 35f8c5e8e37..f81505c1cf1 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -124,6 +124,22 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (nreverse arglist))) ((byte-code-function-p def) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) + ((subrp def) + (let ((arity (subr-arity def)) + (arglist ())) + (dotimes (i (car arity)) + (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) + (cond + ((not (numberp (cdr arglist))) + (push '&rest arglist) + (push 'rest arglist)) + ((< (car arity) (cdr arity)) + (push '&optional arglist) + (dotimes (i (- (cdr arity) (car arity))) + (push (intern (concat "arg" (number-to-string + (+ 1 i (car arity))))) + arglist)))) + (nreverse arglist))) ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) "[Arg list not available until function definition is loaded.]") (t t))) @@ -618,9 +634,9 @@ it is displayed along with the global value." "Describe variable (default %s): " v) "Describe variable: ") obarray - '(lambda (vv) - (or (boundp vv) - (get vv 'variable-documentation))) + (lambda (vv) + (or (special-variable-p vv) + (get vv 'variable-documentation))) t nil nil (if (symbolp v) (symbol-name v)))) (list (if (equal val "") diff --git a/lisp/mpc.el b/lisp/mpc.el index 10e8c9d7688..b1e4d860cca 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -2452,13 +2452,13 @@ This is used so that they can be compared with `eq', which is needed for (defvar mpc-faster-speedup 8) -(defun mpc-ffwd (event) +(defun mpc-ffwd (_event) "Fast forward." (interactive (list last-nonmenu-event)) ;; (mpc--faster event 4.0 1) (mpc--faster-toggle mpc-faster-speedup 1)) -(defun mpc-rewind (event) +(defun mpc-rewind (_event) "Fast rewind." (interactive (list last-nonmenu-event)) ;; (mpc--faster event 4.0 -1) diff --git a/lisp/newcomment.el b/lisp/newcomment.el index d88b76a7759..d3530b1be3e 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -1,4 +1,4 @@ -;;; newcomment.el --- (un)comment regions of buffers +;;; newcomment.el --- (un)comment regions of buffers -*- lexical-binding: t -*- ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. @@ -722,7 +722,7 @@ With any other arg, set comment column to indentation of the previous comment With prefix ARG, kill comments on that many lines starting with this one." (interactive "P") (comment-normalize-vars) - (dotimes (_ (prefix-numeric-value arg)) + (dotimes (i (prefix-numeric-value arg)) (save-excursion (beginning-of-line) (let ((cs (comment-search-forward (line-end-position) t))) diff --git a/lisp/reveal.el b/lisp/reveal.el index 574c86a0fa4..bf18602379c 100644 --- a/lisp/reveal.el +++ b/lisp/reveal.el @@ -1,4 +1,4 @@ -;;; reveal.el --- Automatically reveal hidden text at point +;;; reveal.el --- Automatically reveal hidden text at point -*- lexical-binding: t -*- ;; Copyright (C) 2000-2011 Free Software Foundation, Inc. diff --git a/lisp/simple.el b/lisp/simple.el index 4549a0bb336..f84812570bf 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2827,51 +2827,6 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]." (reset-this-command-lengths) (restore-overriding-map)) -;; This function is here rather than in subr.el because it uses CL. -(defmacro with-wrapper-hook (var args &rest body) - "Run BODY wrapped with the VAR hook. -VAR is a special hook: its functions are called with a first argument -which is the \"original\" code (the BODY), so the hook function can wrap -the original function, or call it any number of times (including not calling -it at all). This is similar to an `around' advice. -VAR is normally a symbol (a variable) in which case it is treated like -a hook, with a buffer-local and a global part. But it can also be an -arbitrary expression. -ARGS is a list of variables which will be passed as additional arguments -to each function, after the initial argument, and which the first argument -expects to receive when called." - (declare (indent 2) (debug t)) - ;; We need those two gensyms because CL's lexical scoping is not available - ;; for function arguments :-( - (let ((funs (make-symbol "funs")) - (global (make-symbol "global")) - (argssym (make-symbol "args"))) - ;; Since the hook is a wrapper, the loop has to be done via - ;; recursion: a given hook function will call its parameter in order to - ;; continue looping. - `(labels ((runrestofhook (,funs ,global ,argssym) - ;; `funs' holds the functions left on the hook and `global' - ;; holds the functions left on the global part of the hook - ;; (in case the hook is local). - (lexical-let ((funs ,funs) - (global ,global)) - (if (consp funs) - (if (eq t (car funs)) - (runrestofhook - (append global (cdr funs)) nil ,argssym) - (apply (car funs) - (lambda (&rest ,argssym) - (runrestofhook (cdr funs) global ,argssym)) - ,argssym)) - ;; Once there are no more functions on the hook, run - ;; the original body. - (apply (lambda ,args ,@body) ,argssym))))) - (runrestofhook ,var - ;; The global part of the hook, if any. - ,(if (symbolp var) - `(if (local-variable-p ',var) - (default-value ',var))) - (list ,@args))))) (defvar filter-buffer-substring-functions nil "Wrapper hook around `filter-buffer-substring'. diff --git a/lisp/subr.el b/lisp/subr.el index b7b5bec1249..b6f095136ff 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1242,6 +1242,67 @@ the hook's buffer-local value rather than its default value." (kill-local-variable hook) (set hook hook-value)))))) +(defmacro letrec (binders &rest body) + "Bind variables according to BINDERS then eval BODY. +The value of the last form in BODY is returned. +Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds +SYMBOL to the value of VALUEFORM. +All symbols are bound before the VALUEFORMs are evalled." + ;; 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). + (declare (debug let) (indent 1)) + `(let ,(mapcar #'car binders) + ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) + ,@body)) + +(defmacro with-wrapper-hook (var args &rest body) + "Run BODY wrapped with the VAR hook. +VAR is a special hook: its functions are called with a first argument +which is the \"original\" code (the BODY), so the hook function can wrap +the original function, or call it any number of times (including not calling +it at all). This is similar to an `around' advice. +VAR is normally a symbol (a variable) in which case it is treated like +a hook, with a buffer-local and a global part. But it can also be an +arbitrary expression. +ARGS is a list of variables which will be passed as additional arguments +to each function, after the initial argument, and which the first argument +expects to receive when called." + (declare (indent 2) (debug t)) + ;; We need those two gensyms because CL's lexical scoping is not available + ;; for function arguments :-( + (let ((funs (make-symbol "funs")) + (global (make-symbol "global")) + (argssym (make-symbol "args")) + (runrestofhook (make-symbol "runrestofhook"))) + ;; Since the hook is a wrapper, the loop has to be done via + ;; recursion: a given hook function will call its parameter in order to + ;; continue looping. + `(letrec ((,runrestofhook + (lambda (,funs ,global ,argssym) + ;; `funs' holds the functions left on the hook and `global' + ;; holds the functions left on the global part of the hook + ;; (in case the hook is local). + (if (consp ,funs) + (if (eq t (car ,funs)) + (funcall ,runrestofhook + (append ,global (cdr ,funs)) nil ,argssym) + (apply (car ,funs) + (apply-partially + (lambda (,funs ,global &rest ,argssym) + (funcall ,runrestofhook ,funs ,global ,argssym)) + (cdr ,funs) ,global) + ,argssym)) + ;; Once there are no more functions on the hook, run + ;; the original body. + (apply (lambda ,args ,@body) ,argssym))))) + (funcall ,runrestofhook ,var + ;; The global part of the hook, if any. + ,(if (symbolp var) + `(if (local-variable-p ',var) + (default-value ',var))) + (list ,@args))))) + (defun add-to-list (list-var element &optional append compare-fn) "Add ELEMENT to the value of LIST-VAR if it isn't there yet. The test for presence of ELEMENT is done with `equal', diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el index 831d4e86676..bc5326240a3 100644 --- a/lisp/textmodes/bibtex-style.el +++ b/lisp/textmodes/bibtex-style.el @@ -1,4 +1,4 @@ -;;; bibtex-style.el --- Major mode for BibTeX Style files +;;; bibtex-style.el --- Major mode for BibTeX Style files -*- lexical-binding: t -*- ;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc. @@ -141,7 +141,7 @@ (looking-at "if\\$")) (scan-error nil)))) (save-excursion - (condition-case err + (condition-case nil (while (progn (backward-sexp 1) (save-excursion (skip-chars-backward " \t{") (not (bolp))))) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index b611261723a..ef51fb25035 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1,4 +1,4 @@ -;;; css-mode.el --- Major mode to edit CSS files +;;; css-mode.el --- Major mode to edit CSS files -*- lexical-binding: t -*- ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. diff --git a/lisp/uniquify.el b/lisp/uniquify.el index e894127cdb1..3153e143ba3 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -1,4 +1,4 @@ -;;; uniquify.el --- unique buffer names dependent on file name +;;; uniquify.el --- unique buffer names dependent on file name -*- lexical-binding: t -*- ;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc. diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 7354e616c99..063eb414579 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -1,4 +1,4 @@ -;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*- +;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8; lexical-binding: t -*- ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. @@ -87,6 +87,12 @@ '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) (defvar cvs-minor-wrap-function) +(defvar cvs-force-command) +(defvar cvs-minor-current-files) +(defvar cvs-secondary-branch-prefix) +(defvar cvs-branch-prefix) +(defvar cvs-tag-print-rev) + (put 'cvs-status-mode 'mode-class 'special) ;;;###autoload (define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" @@ -472,7 +478,7 @@ Optional prefix ARG chooses between two representations." (nprev (if (and cvs-tree-nomerge next (equal vlist (cvs-tag->vlist next))) prev vlist))) - (cvs-map (lambda (v p) v) nprev prev))) + (cvs-map (lambda (v _p) v) nprev prev))) (after (save-excursion (newline) (cvs-tree-tags-insert (cdr tags) nprev))) @@ -512,24 +518,24 @@ Optional prefix ARG chooses between two representations." ;;;; Merged trees from different files ;;;; -(defun cvs-tree-fuzzy-merge-1 (trees tree prev) - ) - -(defun cvs-tree-fuzzy-merge (trees tree) - "Do the impossible: merge TREE into TREES." - ()) - -(defun cvs-tree () - "Get tags from the status output and merge tham all into a big tree." - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t) - (trees (make-vector 31 0)) tree) - (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) - (cvs-tree-fuzzy-merge trees tree)) - (erase-buffer) - (let ((cvs-tag-print-rev nil)) - (cvs-tree-print tree 'cvs-tag->string 3))))) +;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev) +;; ) + +;; (defun cvs-tree-fuzzy-merge (trees tree) +;; "Do the impossible: merge TREE into TREES." +;; ()) + +;; (defun cvs-tree () +;; "Get tags from the status output and merge them all into a big tree." +;; (save-excursion +;; (goto-char (point-min)) +;; (let ((inhibit-read-only t) +;; (trees (make-vector 31 0)) tree) +;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) +;; (cvs-tree-fuzzy-merge trees tree)) +;; (erase-buffer) +;; (let ((cvs-tag-print-rev nil)) +;; (cvs-tree-print tree 'cvs-tag->string 3))))) (provide 'cvs-status) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8e5fe27f965..f55629b3ea1 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -811,7 +811,7 @@ PREFIX is only used internally: don't use it." (defun diff-ediff-patch () "Call `ediff-patch-file' on the current buffer." (interactive) - (condition-case err + (condition-case nil (ediff-patch-file nil (current-buffer)) (wrong-number-of-arguments (ediff-patch-file)))) @@ -1168,7 +1168,7 @@ else cover the whole buffer." ;; *-change-function is asking for trouble, whereas making them ;; from a post-command-hook doesn't pose much problems (defvar diff-unhandled-changes nil) -(defun diff-after-change-function (beg end len) +(defun diff-after-change-function (beg end _len) "Remember to fixup the hunk header. See `after-change-functions' for the meaning of BEG, END and LEN." ;; Ignoring changes when inhibit-read-only is set is strictly speaking @@ -1690,7 +1690,7 @@ With a prefix argument, REVERSE the hunk." "See whether it's possible to apply the current hunk. With a prefix argument, try to REVERSE the hunk." (interactive "P") - (destructuring-bind (buf line-offset pos src dst &optional switched) + (destructuring-bind (buf line-offset pos src _dst &optional switched) (diff-find-source-location nil reverse) (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) @@ -1710,7 +1710,7 @@ then `diff-jump-to-old-file' is also set, for the next invocations." ;; This is a convenient detail when using smerge-diff. (if event (posn-set-point (event-end event))) (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) - (destructuring-bind (buf line-offset pos src dst &optional switched) + (destructuring-bind (buf line-offset pos src _dst &optional switched) (diff-find-source-location other-file rev) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) @@ -1728,7 +1728,7 @@ For use in `add-log-current-defun-function'." (when (looking-at diff-hunk-header-re) (forward-line 1) (re-search-forward "^[^ ]" nil t)) - (destructuring-bind (&optional buf line-offset pos src dst switched) + (destructuring-bind (&optional buf _line-offset pos src dst switched) ;; Use `noprompt' since this is used in which-func-mode and such. (ignore-errors ;Signals errors in place of prompting. (diff-find-source-location nil nil 'noprompt)) @@ -1876,28 +1876,27 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks." ;; good to call it for each change. (save-excursion (goto-char (point-min)) - (let ((orig-buffer (current-buffer))) - (condition-case nil - ;; Call add-change-log-entry-other-window for each hunk in - ;; the diff buffer. - (while (progn - (diff-hunk-next) - ;; Move to where the changes are, - ;; `add-change-log-entry-other-window' works better in - ;; that case. - (re-search-forward - (concat "\n[!+-<>]" - ;; If the hunk is a context hunk with an empty first - ;; half, recognize the "--- NNN,MMM ----" line - "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" - ;; and skip to the next non-context line. - "\\( .*\n\\)*[+]\\)?") - nil t)) - (save-excursion - ;; FIXME: this pops up windows of all the buffers. - (add-change-log-entry nil nil t nil t))) - ;; When there's no more hunks, diff-hunk-next signals an error. - (error nil))))) + (condition-case nil + ;; Call add-change-log-entry-other-window for each hunk in + ;; the diff buffer. + (while (progn + (diff-hunk-next) + ;; Move to where the changes are, + ;; `add-change-log-entry-other-window' works better in + ;; that case. + (re-search-forward + (concat "\n[!+-<>]" + ;; If the hunk is a context hunk with an empty first + ;; half, recognize the "--- NNN,MMM ----" line + "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" + ;; and skip to the next non-context line. + "\\( .*\n\\)*[+]\\)?") + nil t)) + (save-excursion + ;; FIXME: this pops up windows of all the buffers. + (add-change-log-entry nil nil t nil t))) + ;; When there's no more hunks, diff-hunk-next signals an error. + (error nil)))) ;; provide the package (provide 'diff-mode) diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 192ab1f78d2..54a2cb4f196 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -1,4 +1,4 @@ -;;; log-edit.el --- Major mode for editing CVS commit messages +;;; log-edit.el --- Major mode for editing CVS commit messages -*- lexical-binding: t -*- ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. @@ -329,7 +329,7 @@ automatically." (defconst log-edit-header-contents-regexp "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?") -(defun log-edit-match-to-eoh (limit) +(defun log-edit-match-to-eoh (_limit) ;; FIXME: copied from message-match-to-eoh. (let ((start (point))) (rfc822-goto-eoh) @@ -361,7 +361,7 @@ automatically." nil lax))))) ;;;###autoload -(defun log-edit (callback &optional setup params buffer mode &rest ignore) +(defun log-edit (callback &optional setup params buffer mode &rest _ignore) "Setup a buffer to enter a log message. \\The buffer will be put in mode MODE or `log-edit-mode' if MODE is nil. diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index fa731e77a6e..d9a06c8a401 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -1,4 +1,4 @@ -;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output +;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output -*- lexical-binding: t -*- ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. @@ -115,6 +115,7 @@ (autoload 'vc-diff-internal "vc") (defvar cvs-minor-wrap-function) +(defvar cvs-force-command) (defgroup log-view nil "Major mode for browsing log output of RCS/CVS/SCCS." diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 37cdd41ee55..75e3b514531 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1,4 +1,4 @@ -;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts +;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -*- lexical-binding: t -*- ;; Copyright (C) 1999-2011 Free Software Foundation, Inc. diff --git a/src/ChangeLog b/src/ChangeLog index e8b3c57fbd0..bbf7f99bb32 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2011-03-11 Stefan Monnier + + * eval.c (Fprog1, Fprog2): Simplify and use XCDR/XCAR. + (Fdefvar): Remove redundant SYMBOLP check. + (Ffunctionp): Don't signal an error for undefined aliases. + 2011-03-06 Stefan Monnier * bytecode.c (exec_byte_code): Remove old lexical binding slot handling diff --git a/src/eval.c b/src/eval.c index 1f6a5e4a1c6..36c63a5c8a7 100644 --- a/src/eval.c +++ b/src/eval.c @@ -371,13 +371,12 @@ usage: (prog1 FIRST BODY...) */) do { + Lisp_Object tem = eval_sub (XCAR (args_left)); if (!(argnum++)) - val = eval_sub (Fcar (args_left)); - else - eval_sub (Fcar (args_left)); - args_left = Fcdr (args_left); + val = tem; + args_left = XCDR (args_left); } - while (!NILP(args_left)); + while (CONSP (args_left)); UNGCPRO; return val; @@ -406,13 +405,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */) do { + Lisp_Object tem = eval_sub (XCAR (args_left)); if (!(argnum++)) - val = eval_sub (Fcar (args_left)); - else - eval_sub (Fcar (args_left)); - args_left = Fcdr (args_left); + val = tem; + args_left = XCDR (args_left); } - while (!NILP (args_left)); + while (CONSP (args_left)); UNGCPRO; return val; @@ -791,9 +789,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) tem = Fdefault_boundp (sym); if (!NILP (tail)) { - if (SYMBOLP (sym)) - /* Do it before evaluating the initial value, for self-references. */ - XSYMBOL (sym)->declared_special = 1; + /* Do it before evaluating the initial value, for self-references. */ + XSYMBOL (sym)->declared_special = 1; if (SYMBOL_CONSTANT_P (sym)) { @@ -2873,7 +2870,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, { if (SYMBOLP (object) && !NILP (Ffboundp (object))) { - object = Findirect_function (object, Qnil); + object = Findirect_function (object, Qt); if (CONSP (object) && EQ (XCAR (object), Qautoload)) { -- cgit v1.2.3 From 2ec42da9f0ddaaa9197617eb3e5a9d18ad2ba942 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 11 Mar 2011 22:32:43 -0500 Subject: Try and fix w32 build; misc cleanup. * lisp/subr.el (apply-partially): Move from subr.el; don't use lexical-let. (eval-after-load): Obey lexical-binding. * lisp/simple.el (apply-partially): Move to subr.el. * lisp/makefile.w32-in: Match changes in Makefile.in. (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS): New vars. (.el.elc, compile-CMD, compile-SH, compile-always-CMD) (compile-always-SH, compile-calc-CMD, compile-calc-SH): Use them. (COMPILE_FIRST): Add pcase, macroexp, and cconv. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Silence warning about calling CL's `compiler-macroexpand'. * lisp/emacs-lisp/bytecomp.el (byte-compile-preprocess): New function. (byte-compile-initial-macro-environment) (byte-compile-toplevel-file-form, byte-compile, byte-compile-sexp): Use it. (byte-compile-eval, byte-compile-eval-before-compile): Obey lexical-binding. (byte-compile--for-effect): Rename from `for-effect'. (display-call-tree): Use case. * lisp/emacs-lisp/byte-opt.el (for-effect): Don't declare as dynamic. (byte-optimize-form-code-walker, byte-optimize-form): Revert to old arg name. * lisp/Makefile.in (BYTE_COMPILE_FLAGS): New var. (compile-onefile, .el.elc, compile-calc, recompile): Use it. --- lisp/ChangeLog | 26 ++++ lisp/Makefile.in | 11 +- lisp/emacs-lisp/byte-opt.el | 33 +++-- lisp/emacs-lisp/bytecomp.el | 298 +++++++++++++++++++++++--------------------- lisp/emacs-lisp/cconv.el | 1 - lisp/emacs-lisp/macroexp.el | 6 +- lisp/makefile.w32-in | 34 +++-- lisp/simple.el | 50 +++----- lisp/subr.el | 13 ++ 9 files changed, 264 insertions(+), 208 deletions(-) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0b432eb46d9..01571b80124 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,29 @@ +2011-03-12 Stefan Monnier + + * subr.el (apply-partially): Move from subr.el; don't use lexical-let. + (eval-after-load): Obey lexical-binding. + * simple.el (apply-partially): Move to subr.el. + * makefile.w32-in: Match changes in Makefile.in. + (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS): New vars. + (.el.elc, compile-CMD, compile-SH, compile-always-CMD) + (compile-always-SH, compile-calc-CMD, compile-calc-SH): Use them. + (COMPILE_FIRST): Add pcase, macroexp, and cconv. + * emacs-lisp/macroexp.el (macroexpand-all-1): Silence warning about + calling CL's `compiler-macroexpand'. + * emacs-lisp/bytecomp.el (byte-compile-preprocess): New function. + (byte-compile-initial-macro-environment) + (byte-compile-toplevel-file-form, byte-compile, byte-compile-sexp): + Use it. + (byte-compile-eval, byte-compile-eval-before-compile): + Obey lexical-binding. + (byte-compile--for-effect): Rename from `for-effect'. + (display-call-tree): Use case. + * emacs-lisp/byte-opt.el (for-effect): Don't declare as dynamic. + (byte-optimize-form-code-walker, byte-optimize-form): + Revert to old arg name. + * Makefile.in (BYTE_COMPILE_FLAGS): New var. + (compile-onefile, .el.elc, compile-calc, recompile): Use it. + 2011-03-11 Stefan Monnier * subr.el (letrec): New macro. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 268a45d8948..4db5ef4f008 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -77,6 +77,8 @@ AUTOGENEL = loaddefs.el \ BIG_STACK_DEPTH = 1200 BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" +BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) + # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. @@ -205,7 +207,7 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - @$(emacs) $(BIG_STACK_OPTS) -l bytecomp $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BYTE_COMPILE_FLAGS) -l bytecomp \ -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) @@ -225,7 +227,7 @@ compile-onefile: @# The BIG_STACK_OPTS are only needed to byte-compile the byte-compiler @# files, which is normally done in compile-first, but may also be @# recompiled via this rule. - @$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BYTE_COMPILE_FLAGS) \ -f batch-byte-compile $< .PHONY: compile-first compile-main compile compile-always @@ -291,7 +293,7 @@ compile-always: doit compile-calc: for el in $(lisp)/calc/*.el; do \ echo Compiling $$el; \ - $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ done # Backup compiled Lisp files in elc.tar.gz. If that file already @@ -318,7 +320,8 @@ compile-after-backup: backup-compiled-files compile-always # since the environment of later files is affected by definitions in # earlier ones. recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc - $(emacs) --eval "(batch-byte-recompile-directory 0)" $(lisp) + $(emacs) $(BYTE_COMPILE_FLAGS) \ + --eval "(batch-byte-recompile-directory 0)" $(lisp) # Update MH-E internal autoloads. These are not to be confused with # the autoloads for the MH-E entry points, which are already in loaddefs.el. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index a4254bfeca1..b07d61ae0d1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -308,9 +308,9 @@ ;; ((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). 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. + ;; (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))) @@ -378,9 +378,7 @@ ;;; implementing source-level optimizers -(defvar for-effect) - -(defun byte-optimize-form-code-walker (form for-effect-arg) +(defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But ;; we need to have special knowledge of the syntax of the special forms @@ -388,8 +386,7 @@ ;; the important aspect is that they are subrs that don't evaluate all of ;; their args.) ;; - (let ((for-effect for-effect-arg) - (fn (car-safe form)) + (let ((fn (car-safe form)) tmp) (cond ((not (consp form)) (if (not (and for-effect @@ -482,8 +479,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. @@ -498,7 +495,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) @@ -537,8 +535,8 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) - ((eq fn 'internal-make-closure) - form) + ;; Neeeded as long as we run byte-optimize-form after cconv. + ((eq fn 'internal-make-closure) form) ((not (symbolp fn)) (debug) @@ -589,19 +587,18 @@ (setq list (cdr list))) constant)) -(defun byte-optimize-form (form &optional for-effect-arg) +(defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." ;; ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect-arg)) + (setq form (byte-optimize-form-code-walker form for-effect)) ;; ;; after optimizing all subforms, optimize this form until it doesn't ;; optimize any further. This means that some forms will be passed through ;; the optimizer many times, but that's necessary to make the for-effect ;; processing do as much as possible. ;; - (let ((for-effect for-effect-arg) - opt new) + (let (opt new) (if (and (consp form) (symbolp (car form)) (or (and for-effect @@ -618,7 +615,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. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c661e6bea7a..729d91eb1c5 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -33,8 +33,7 @@ ;;; Code: -;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-" -;; variable prefix. +;; FIXME: get rid of the atrocious "bytecomp-" variable prefix. ;; ======================================================================== ;; Entry points: @@ -432,12 +431,9 @@ This list lives partly on the stack.") (eval-when-compile . (lambda (&rest body) (list 'quote - ;; FIXME: is that right in lexbind code? (byte-compile-eval (byte-compile-top-level - (macroexpand-all - (cons 'progn body) - byte-compile-initial-macro-environment)))))) + (byte-compile-preprocess (cons 'progn body))))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -692,7 +688,7 @@ otherwise pop it") ;; if (following one byte & 0x80) == 0 ;; discard (following one byte & 0x7F) stack entries ;; else -;; discard (following one byte & 0x7F) stack entries _underneath_ the top of stack +;; 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 @@ -829,9 +825,11 @@ CONST2 may be evaulated multiple times." ;; 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) + (byte-compile-push-bytecodes opcode (logior #x7f flag) + bytes pc) (setq off (- off #x7f))) - (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + (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)) @@ -875,7 +873,7 @@ CONST2 may be evaulated multiple times." 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)) @@ -927,7 +925,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. @@ -1018,7 +1016,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) @@ -1030,7 +1029,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))) @@ -1093,13 +1093,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. @@ -1325,7 +1327,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)))))) @@ -1873,7 +1875,8 @@ 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)) @@ -2072,7 +2075,7 @@ Call from the source buffer." nil))) (defvar print-gensym-alist) ;Used before print-circle existed. -(defvar for-effect) +(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). @@ -2147,8 +2150,10 @@ 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) + bytecomp-outbuffer) (setq form (cdr form)) (setq index (1+ index)))) ((= index (nth 1 info)) @@ -2170,14 +2175,14 @@ list that represents a doc string reference. (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form t))) (if bytecomp-handler - (let ((for-effect t)) + (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 + (if byte-compile--for-effect (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -2195,13 +2200,22 @@ 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. - (setq form (macroexpand-all form byte-compile-macro-environment)) - (if lexical-binding - (setq form (cconv-closure-convert form))) - (byte-compile-file-form form))) + (byte-compile-file-form (byte-compile-preprocess form t)))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2272,7 +2286,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)) @@ -2542,11 +2557,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) ;; Expand macros. - (setq fun - (macroexpand-all fun - byte-compile-initial-macro-environment)) - (if lexical-binding - (setq fun (cconv-closure-convert fun))) + (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 @@ -2560,7 +2571,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)))) + (byte-compile-top-level (byte-compile-preprocess sexp))))) ;; Given a function made by byte-compile-lambda, make a form which produces it. (defun byte-compile-byte-code-maker (fun) @@ -2815,14 +2826,14 @@ 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-arg 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 ((for-effect for-effect-arg) + (let ((byte-compile--for-effect for-effect) (byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0) @@ -2832,7 +2843,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (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))) + (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))) (if (and (eq 'byte-code (car-safe form)) @@ -2850,11 +2861,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (> byte-compile-depth 0) (byte-compile-out-tag (byte-compile-make-tag)))) ;; Now compile FORM - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (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-arg output-type) - (if for-effect-arg +(defun byte-compile-out-toplevel (&optional for-effect output-type) + (if for-effect ;; The stack is empty. Push a value to be returned from (byte-code ..). (if (eq (car (car byte-compile-output)) 'byte-discard) (setq byte-compile-output (cdr byte-compile-output)) @@ -2890,7 +2901,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; progn -> as <> or (progn <> atom) ;; file -> as progn, but takes both quotes and atoms, and longer forms. (let (rest - (for-effect for-effect-arg) + (byte-compile--for-effect for-effect) (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. tmp body) (cond @@ -2902,34 +2913,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))) @@ -2940,9 +2952,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((car body))))) ;; Given BYTECOMP-BODY, compile it and return a new body. -(defun byte-compile-top-level-body (bytecomp-body &optional for-effect-arg) +(defun byte-compile-top-level-body (bytecomp-body &optional for-effect) (setq bytecomp-body - (byte-compile-top-level (cons 'progn bytecomp-body) for-effect-arg t)) + (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) (cdr bytecomp-body)) (bytecomp-body @@ -2966,25 +2978,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; 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-arg) - (let ((for-effect for-effect-arg)) +(defun byte-compile-form (form &optional for-effect) + (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 for-effect byte-compile-delete-errors) + ((and byte-compile--for-effect byte-compile-delete-errors) (when (symbolp form) (byte-compile-set-symbol-position form)) - (setq for-effect nil)) + (setq byte-compile--for-effect nil)) (t (byte-compile-variable-ref form)))) ((symbolp (car form)) @@ -3018,10 +3032,10 @@ That command is designed for interactive use only" bytecomp-fn)) ;; 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-form form byte-compile--for-effect) + (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) - (if for-effect + (if byte-compile--for-effect (byte-compile-discard)))) (defun byte-compile-normal-call (form) @@ -3037,7 +3051,7 @@ That command is designed for interactive use only" bytecomp-fn)) (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 @@ -3119,18 +3133,19 @@ If BINDING is non-nil, VAR is being bound." (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 @@ -3335,7 +3350,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-constant nil)) (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). + "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." @@ -3357,7 +3373,7 @@ discarding." (setq num (1- num))))) (defun byte-compile-stack-ref (stack-pos) - "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." + "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 @@ -3366,7 +3382,7 @@ discarding." (byte-compile-out 'byte-stack-ref dist)))) (defun byte-compile-stack-set (stack-pos) - "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." + "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) @@ -3375,7 +3391,7 @@ discarding." (defconst byte-compile--env-var (make-symbol "env")) (defun byte-compile-make-closure (form) - (if for-effect (setq for-effect nil) + (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) (body (nthcdr 3 form)) @@ -3389,7 +3405,7 @@ discarding." (defun byte-compile-get-closed-var (form) - (if for-effect (setq for-effect nil) + (if byte-compile--for-effect (setq byte-compile--for-effect nil) (byte-compile-out 'byte-constant ;; byte-closed-var (nth 1 form)))) @@ -3597,13 +3613,13 @@ discarding." (if bytecomp-args (while bytecomp-args (byte-compile-form (car (cdr bytecomp-args))) - (or for-effect (cdr (cdr bytecomp-args)) + (or byte-compile--for-effect (cdr (cdr bytecomp-args)) (byte-compile-out 'byte-dup 0)) (byte-compile-variable-set (car bytecomp-args)) (setq bytecomp-args (cdr (cdr bytecomp-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)) @@ -3637,19 +3653,19 @@ discarding." ;;; control structures -(defun byte-compile-body (bytecomp-body &optional for-effect-arg) +(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-arg)) + (byte-compile-form (car bytecomp-body) for-effect)) (defsubst byte-compile-body-do-effect (bytecomp-body) - (byte-compile-body bytecomp-body for-effect) - (setq for-effect nil)) + (byte-compile-body bytecomp-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) @@ -3729,9 +3745,9 @@ that suppresses all warnings during execution of BODY." (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 @@ -3753,20 +3769,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)) @@ -3783,18 +3799,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))) @@ -3813,7 +3829,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)) @@ -3832,7 +3848,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)) @@ -3843,11 +3859,11 @@ 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)) @@ -4008,7 +4024,7 @@ binding slots have been popped." (byte-compile-form `(list 'funcall ,f))) (body (byte-compile-push-constant - (byte-compile-top-level (cons 'progn body) for-effect)))) + (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) (byte-compile-out 'byte-catch 0)) (defun byte-compile-unwind-protect (form) @@ -4044,7 +4060,7 @@ binding slots have been popped." (if fun-bodies (byte-compile-form `(list 'funcall ,(nth 2 form))) (byte-compile-push-constant - (byte-compile-top-level (nth 2 form) for-effect))) + (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) (let ((compiled-clauses (mapcar (lambda (clause) @@ -4072,7 +4088,7 @@ binding slots have been popped." `(list ',condition (list 'funcall ,(cadr clause) ',var)) (cons condition (byte-compile-top-level-body - (cdr clause) for-effect))))) + (cdr clause) byte-compile--for-effect))))) (cdr (cdr (cdr form)))))) (if fun-bodies (byte-compile-form `(list ,@compiled-clauses)) @@ -4113,7 +4129,7 @@ binding slots have been popped." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - (let ((for-effect nil)) + (let ((byte-compile--for-effect nil)) (byte-compile-push-constant 'defalias) (byte-compile-push-constant (nth 1 form)) (byte-compile-closure (cdr (cdr form)) t)) @@ -4410,22 +4426,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)) @@ -4533,7 +4549,8 @@ 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")) @@ -4558,7 +4575,8 @@ already up-to-date." ;; Specific file argument (if (or (not noforce) (let* ((bytecomp-source (car command-line-args-left)) - (bytecomp-dest (byte-compile-dest-file bytecomp-source))) + (bytecomp-dest (byte-compile-dest-file + bytecomp-source))) (or (not (file-exists-p bytecomp-dest)) (file-newer-than-file-p bytecomp-source bytecomp-dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5be84c15d89..2229be0de58 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -67,7 +67,6 @@ ;; TODO: ;; - byte-optimize-form should be applied before cconv. -;; - maybe unify byte-optimize and compiler-macros. ;; - 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 diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 55ca90597d1..f0a075ace37 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -183,7 +183,9 @@ Assumes the caller has bound `macroexpand-all-environment'." (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args))))) - ;; Macro expand compiler macros. + ;; 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) @@ -191,7 +193,7 @@ Assumes the caller has bound `macroexpand-all-environment'." 'cl-byte-compile-compiler-macro) (functionp 'compiler-macroexpand)))) . ,_) - (let ((newform (compiler-macroexpand form))) + (let ((newform (with-no-warnings (compiler-macroexpand form)))) (if (eq form newform) (macroexpand-all-forms form 1) (macroexpand-all-1 newform)))) diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in index 0e3d54408fd..088410172e6 100644 --- a/lisp/makefile.w32-in +++ b/lisp/makefile.w32-in @@ -66,6 +66,15 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \ $(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \ $(lisp)/cedet/srecode/loaddefs.el +# Value of max-lisp-eval-depth when compiling initially. +# During bootstrapping the byte-compiler is run interpreted when compiling +# itself, and uses more stack than usual. +# +BIG_STACK_DEPTH = 1200 +BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" + +BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) + # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. The CC files are compiled first # because CC mode tweaks the compilation process, and requiring @@ -75,6 +84,9 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \ COMPILE_FIRST = \ $(lisp)/emacs-lisp/byte-opt.el \ $(lisp)/emacs-lisp/bytecomp.el \ + $(lisp)/emacs-lisp/pcase.elc \ + $(lisp)/emacs-lisp/macroexp.elc \ + $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/subr.el \ $(lisp)/progmodes/cc-mode.el \ $(lisp)/progmodes/cc-vars.el @@ -287,7 +299,7 @@ TAGS-LISP-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsf .SUFFIXES: .elc .el .el.elc: - -$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< + -$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< # Compile all Lisp files, but don't recompile those that are up to # date. Some files don't actually get compiled because they set the @@ -307,22 +319,22 @@ compile: $(lisp)/subdirs.el mh-autoloads compile-$(SHELLTYPE) doit compile-CMD: # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g for %%f in ($(COMPILE_FIRST)) do \ - $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f + $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \ - $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g + $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g compile-SH: # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done for el in $(COMPILE_FIRST); do \ echo Compiling $$el; \ - $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ + $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \ done for dir in $(lisp) $(WINS); do \ for el in $$dir/*.el; do \ if test -f $$el; \ then \ echo Compiling $$el; \ - $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ + $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \ fi \ done; \ done @@ -335,31 +347,31 @@ compile-always: $(lisp)/subdirs.el compile-always-$(SHELLTYPE) doit compile-always-CMD: # -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g - for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f - for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f/%%g + for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f + for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f/%%g compile-always-SH: # for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done for el in $(COMPILE_FIRST); do \ echo Compiling $$el; \ - $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ done for dir in $(lisp) $(WINS); do \ for el in $$dir/*.el; do \ echo Compiling $$el; \ - $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ done; \ done compile-calc: compile-calc-$(SHELLTYPE) compile-calc-CMD: - for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f + for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f compile-calc-SH: for el in $(lisp)/calc/*.el; do \ echo Compiling $$el; \ - $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ done # Backup compiled Lisp files in elc.tar.gz. If that file already diff --git a/lisp/simple.el b/lisp/simple.el index f84812570bf..7a191f0cc9a 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -28,8 +28,7 @@ ;;; Code: -;; This is for lexical-let in apply-partially. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl)) ;For define-minor-mode. (declare-function widget-convert "wid-edit" (type &rest args)) (declare-function shell-mode "shell" ()) @@ -6605,38 +6604,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil." buffer-invisibility-spec) (setq buffer-invisibility-spec nil))) -;; Partial application of functions (similar to "currying"). -;; This function is here rather than in subr.el because it uses CL. -;; (defalias 'apply-partially #'curry) -(defun apply-partially (fun &rest args) - "Return a function that is a partial application of FUN to ARGS. -ARGS is a list of the first N arguments to pass to FUN. -The result is a new function which does the same as FUN, except that -the first N arguments are fixed at the values with which this function -was called." - (lexical-let ((fun fun) (args1 args)) - (lambda (&rest args2) (apply fun (append args1 args2))))) - ;; Minibuffer prompt stuff. -;(defun minibuffer-prompt-modification (start end) -; (error "You cannot modify the prompt")) -; -; -;(defun minibuffer-prompt-insertion (start end) -; (let ((inhibit-modification-hooks t)) -; (delete-region start end) -; ;; Discard undo information for the text insertion itself -; ;; and for the text deletion.above. -; (when (consp buffer-undo-list) -; (setq buffer-undo-list (cddr buffer-undo-list))) -; (message "You cannot modify the prompt"))) -; -; -;(setq minibuffer-prompt-properties -; (list 'modification-hooks '(minibuffer-prompt-modification) -; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) -; +;;(defun minibuffer-prompt-modification (start end) +;; (error "You cannot modify the prompt")) +;; +;; +;;(defun minibuffer-prompt-insertion (start end) +;; (let ((inhibit-modification-hooks t)) +;; (delete-region start end) +;; ;; Discard undo information for the text insertion itself +;; ;; and for the text deletion.above. +;; (when (consp buffer-undo-list) +;; (setq buffer-undo-list (cddr buffer-undo-list))) +;; (message "You cannot modify the prompt"))) +;; +;; +;;(setq minibuffer-prompt-properties +;; (list 'modification-hooks '(minibuffer-prompt-modification) +;; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) ;;;; Problematic external packages. diff --git a/lisp/subr.el b/lisp/subr.el index b6f095136ff..5faaa2130a2 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions. ;; depend on backquote.el. (list 'function (cons 'lambda cdr))) +;; Partial application of functions (similar to "currying"). +;; This function is here rather than in subr.el because it uses CL. +(defun apply-partially (fun &rest args) + "Return a function that is a partial application of FUN to ARGS. +ARGS is a list of the first N arguments to pass to FUN. +The result is a new function which does the same as FUN, except that +the first N arguments are fixed at the values with which this function +was called." + `(closure () lambda (&rest args) + (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args))) + (if (null (featurep 'cl)) (progn ;; If we reload subr.el after having loaded CL, be careful not to @@ -1675,6 +1686,8 @@ This function makes or adds to an entry on `after-load-alist'." (unless elt (setq elt (list regexp-or-feature)) (push elt after-load-alist)) + ;; Make sure `form' is evalled in the current lexical/dynamic code. + (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding))) (when (symbolp regexp-or-feature) ;; For features, the after-load-alist elements get run when `provide' is ;; called rather than at the end of the file. So add an indirection to -- cgit v1.2.3