From b9598260f96ddc652cd82ab64bbe922ccfc48a29 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 13 Jun 2010 16:36:17 -0400 Subject: [PATCH] New branch for lexbind, losing all history. This initial patch is based on 2002-06-27T22:39:10Z!storm@cua.dk of the original lexbind branch. --- doc/lispref/elisp.texi | 7 +- doc/lispref/functions.texi | 72 ++- doc/lispref/objects.texi | 61 ++- doc/lispref/vol1.texi | 2 +- doc/lispref/vol2.texi | 2 +- etc/NEWS.lexbind | 55 ++ lisp/ChangeLog.funvec | 10 + lisp/ChangeLog.lexbind | 256 +++++++++ lisp/Makefile.in | 9 +- lisp/emacs-lisp/byte-lexbind.el | 696 +++++++++++++++++++++++++ lisp/emacs-lisp/byte-opt.el | 263 ++++++++-- lisp/emacs-lisp/bytecomp.el | 884 +++++++++++++++++++++++--------- lisp/emacs-lisp/disass.el | 15 +- lisp/emacs-lisp/lisp-mode.el | 10 +- lisp/help-fns.el | 65 ++- lisp/subr.el | 6 + src/ChangeLog.funvec | 37 ++ src/ChangeLog.lexbind | 104 ++++ src/alloc.c | 76 ++- src/buffer.c | 1 + src/bytecode.c | 128 ++++- src/data.c | 28 +- src/doc.c | 11 +- src/eval.c | 377 ++++++++++++-- src/fns.c | 25 +- src/image.c | 2 +- src/keyboard.c | 2 +- src/lisp.h | 44 +- src/lread.c | 194 ++++++- src/print.c | 6 +- 30 files changed, 3032 insertions(+), 416 deletions(-) create mode 100644 etc/NEWS.lexbind create mode 100644 lisp/ChangeLog.funvec create mode 100644 lisp/ChangeLog.lexbind create mode 100644 lisp/emacs-lisp/byte-lexbind.el create mode 100644 src/ChangeLog.funvec create mode 100644 src/ChangeLog.lexbind diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 0f74618721..46d242fcfb 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -248,7 +248,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. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Funvec Type:: A vector type callable as a function. * Autoload Type:: A type used for automatically loading seldom-used functions. @@ -463,10 +463,11 @@ 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. + that have a special bearing on how functions work. Lambda Expressions diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 37e8726592..7e8ac09b44 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -22,7 +22,9 @@ define them. * Function Cells:: Accessing or setting the function definition of a symbol. * Obsolete Functions:: Declaring functions obsolete. -* Inline Functions:: Defining functions that the compiler will open code. +* 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 @@ -111,7 +113,25 @@ 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. @xref{Byte-Code Type}. +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 + @end table @defun functionp object @@ -152,6 +172,11 @@ 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 @@ -1277,6 +1302,49 @@ 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 5c3ac13cda..1a72fdf671 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -157,7 +157,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. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Funvec Type:: A vector type callable as a function. * Autoload Type:: A type used for automatically loading seldom-used functions. @end menu @@ -1315,18 +1315,55 @@ with the name of the subroutine. @end group @end example -@node Byte-Code Type -@subsection Byte-Code Function Type +@node Funvec Type +@subsection ``Function Vector' Type +@cindex function vector +@cindex funvec -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. +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 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{[}. +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 @node Autoload Type @subsection Autoload Type @@ -1773,7 +1810,7 @@ with references to further information. @xref{Buffer Basics, bufferp}. @item byte-code-function-p -@xref{Byte-Code Type, byte-code-function-p}. +@xref{Funvec 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 a0590c3d28..052d83eacd 100644 --- a/doc/lispref/vol1.texi +++ b/doc/lispref/vol1.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. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Funvec Type:: A vector type callable as a function. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/doc/lispref/vol2.texi b/doc/lispref/vol2.texi index ad4c74611a..d6358f3ecf 100644 --- a/doc/lispref/vol2.texi +++ b/doc/lispref/vol2.texi @@ -267,7 +267,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. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Funvec Type:: A vector type callable as a function. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind new file mode 100644 index 0000000000..372ee6827c --- /dev/null +++ b/etc/NEWS.lexbind @@ -0,0 +1,55 @@ +GNU Emacs NEWS -- history of user-visible changes. + +Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 + Free Software Foundation, Inc. +See the end of the file for license conditions. + +Please send Emacs bug reports to bug-gnu-emacs@gnu.org. +If possible, use M-x report-emacs-bug. + +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 + + + +---------------------------------------------------------------------- +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 2, 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; see the file COPYING. If not, write to the +Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. + + +Local variables: +mode: outline +paragraph-separate: "[ ]*$" +end: + +arch-tag: d5ab31ab-2041-4b15-a1a9-e7c42693060c diff --git a/lisp/ChangeLog.funvec b/lisp/ChangeLog.funvec new file mode 100644 index 0000000000..0a31b9a590 --- /dev/null +++ b/lisp/ChangeLog.funvec @@ -0,0 +1,10 @@ +2004-05-20 Miles Bader + + * subr.el (functionp): Use `funvecp' instead of + `byte-compiled-function-p'. + * help-fns.el (describe-function-1): Describe curried functions + and other funvecs as such. + (help-highlight-arguments): Only format things that look like a + function. + +;; arch-tag: 87f75aac-de53-40d7-96c7-3befaa771cb1 diff --git a/lisp/ChangeLog.lexbind b/lisp/ChangeLog.lexbind new file mode 100644 index 0000000000..ca491f961d --- /dev/null +++ b/lisp/ChangeLog.lexbind @@ -0,0 +1,256 @@ +2006-12-04 Miles Bader + + * Makefile.in (COMPILE_FIRST_STACK_DEPTH): New variable. + (compile, compile-always): Use it. + +2005-10-24 Miles Bader + + * subr.el (functionp): Re-remove. + + * emacs-lisp/bytecomp.el (byte-compile-closure): Add optional + ADD-LAMBDA argument, which we just pass to `byte-compile-lambda'. + (byte-compile-defun): Use ADD-LAMBDA arg to `byte-compile-closure' + instead of adding lambda ourselves. + +2004-08-09 Miles Bader + + Changes from merging the funvec patch: + + * emacs-lisp/bytecomp.el (byte-compile-make-closure): Use `curry' + instead of `vector' to create compiled closures. + + Merge funvec patch. + +2004-04-29 Miles Bader + + * emacs-lisp/bytecomp.el (byte-compile-top-level): Add new entries + to `byte-compile-lexical-environment' at the start, not end. + (byte-compile-delay-out): Correctly default STACK-ADJUST to zero. + + * emacs-lisp/byte-opt.el (byte-opt-update-stack-params): Don't + crash on no-op lapcode entries (car is nil). + + * emacs-lisp/byte-lexbind.el (byte-compile-make-lambda-lexenv): + Push a lexvar onto lexenv, not a vinfo! + +2004-04-11 Miles Bader + + * emacs-lisp/bytecomp.el (byte-compile-top-level): Correctly + analyze lexically-bound arguments. + + * emacs-lisp/byte-lexbind.el (byte-compile-lforminfo-analyze): + Use `append' instead of `nconc'. + + * emacs-lisp/byte-lexbind.el (byte-compile-make-lvarinfo): Don't + use backquote to make a mutable data-structure. + (byte-compile-lvarinfo-num-refs, byte-compile-lvarinfo-num-sets): + Renamed to use `num-' instead of `num'. + (byte-compile-make-lambda-lexenv): Adjusted accordingly. + +2004-04-10 Miles Bader + + * emacs-lisp/byte-lexbind.el (byte-compile-compute-lforminfo): + Look at variable's global specialp state too. + +2004-04-09 Miles Bader + + * emacs-lisp/byte-opt.el (byte-optimize-lapcode): Default + initial-stack-depth to 0. + (byte-optimize-lapcode): Discard the right number of values in + the stack-set+discard-->discard optimization. + +2004-04-02 Miles Bader + + * emacs-lisp/lisp-mode.el (eval-last-sexp-1): Setup the lexical + environment if lexical-binding is enabled. + +2003-10-14 Miles Bader + + * emacs-lisp/macroexp.el (macroexpand-all-1): Special-case + `backquote-list*' to avoid stack overflows. + +2003-04-04 Miles Bader + + * help-fns.el (help-function-arglist): Handle interpreted closures. + +2002-11-20 Miles Bader + + * emacs-lisp/bytecomp.el (byte-compile-stack-adjustment): + Correctly handle discardN* operators. + * emacs-lisp/byte-opt.el (byte-optimize-lapcode): Fix stack-depth + tracking errors. + +2002-08-26 Miles Bader + + * international/mule.el (make-char): Macroexpand call to + charset-id constructed by `byte-compile' hook. + + * emacs-lisp/macroexp.el (macroexpand-all-1): Expand defconst value. + + * emacs-lisp/byte-opt.el (byte-opt-update-stack-params): New macro. + (byte-optimize-lapcode): Keep track of stack-depth in final pass too. + Add more optimizations for lexical binding. + (byte-compile-inline-expand): Macroexpand result of inlining. + + * emacs-lisp/bytecomp.el (byte-compile-lambda): Update call to + byte-compile-closure-initial-lexenv-p. + (byte-discardN-preserve-tos): Alias to byte-discardN. + (byte-compile-push-binding-init): Don't push unused variables on + init-lexenv. + (byte-compile-push-binding-init): Don't use LFORMINFO if it's nil. + (byte-compile-lambda): Don't look at lexical environment unless + we're using lexical binding. + (byte-compile-defmacro): Correctly generate macros. + + * emacs-lisp/byte-lexbind.el (byte-compile-unbind): Optimize the + dynamic-bindings-only case. + (byte-compile-bind): Don't special-case unused lexical variables. + + * emacs-lisp/disass.el (disassemble-1): Print arg for discardN ops. + +2002-08-19 Miles Bader + + * emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Handle + `byte-discardN-preserve-tos' pseudo-op. + (byte-compile-side-effect-and-error-free-ops): Add `byte-stack-ref'. + (byte-compile-side-effect-free-ops): Add `byte-vec-ref'. + (byte-optimize-lapcode): Add some cases for stack-set/ref ops. + Add tracking of stack-depth. Unfinished code to collapse + lexical-unbinding sequences. + + * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle + `byte-discardN-preserve-tos' pseudo-op. + (byte-compile-top-level): If there are lexical args, output a TAG + op to record the initial stack-depth for the optimizer. + +2002-08-17 Miles Bader + + * emacs-lisp/bytecomp.el (byte-discardN): Add byte-defop. + (byte-compile-lapcode): Include byte-discardN. + (byte-compile-lambda): Fixup closure detection. + (byte-compile-top-level): Handle arguments for a lexical lambda. + (byte-compile-lexical-variable-ref, byte-compile-variable-ref) + (byte-compile-variable-set): Use byte-compile-stack-set/ref. + (byte-compile-discard): Add new parameters NUM and PRESERVE-TOS. + (byte-compile-stack-ref, byte-compile-stack-set): New functions. + (byte-compile-push-binding-init): Get the variable list properly + from LFORMINFO. + + * emacs-lisp/byte-lexbind.el (byte-compile-lforminfo-analyze): + Ignore setq'd variables we're not interested in. + (byte-compile-make-lambda-lexenv): Add assertion that closed-over + variables be heap allocated. + (byte-compile-closure-initial-lexenv-p): Renamed from + byte-compile-closure-lexenv-p. + (byte-compile-non-stack-bindings-p): Get the variable list + properly from LFORMINFO. + (byte-compile-maybe-push-heap-environment): Handle the + no-closed-over-variables case correctly. + (byte-compile-bind): Use byte-compile-stack-set/ref. + Don't bother modifying INIT-LEXENV as no one will see the changes. + (byte-compile-unbind): Call `byte-compile-discard' to handle + unbinding lexical bindings. + + * emacs-lisp/disass.el (disassemble-internal): Handle closures. + (disassemble-1): Handle new bytecodes. + * emacs-lisp/byte-opt.el (disassemble-offset): Handle new bytecodes. + +2002-06-16 Miles Bader + + * emacs-lisp/macroexp.el (macroexp-accumulate): New macro. + (macroexpand-all-forms, macroexpand-all-clauses): Use it. + * Makefile.in (compile): Undo previous change. + +2002-06-14 Miles Bader + + * Makefile.in (COMPILE_FIRST): Add `emacs-lisp/macroexp.el'. + (compile): Add a special case that compiles `emacs-lisp/macroexp.el' + with an increased max-lisp-eval-depth. + + * emacs-lisp/bytecomp.el: Provide `bytecomp-preload', at the + beginning of the file. Require `byte-lexbind' at compile time. + Add a few doc string. + (byte-compile-push-bytecodes) + (byte-compile-push-bytecode-const2): New macros. + (byte-compile-lapcode): Use them. Do general code cleanup. + (byte-compile-initial-macro-environment): Expand macros in + byte-compile-eval before passing to byte-compile-top-level. + (byte-compile): Use the `byte-compile-initial-macro-environment'. + + * emacs-lisp/byte-lexbind.el: Require `bytecomp-preload' instead of + `bytecomp'. + (byte-compile-bind): Use `byte-compile-dynamic-variable-bind' to bind + dynamic variables. + (byte-compile-maybe-push-heap-environment): Fix function name typo. + +2002-06-13 Miles Bader + + Byte compiler lexical binding support (not finished yet): + * emacs-lisp/bytecomp.el: Require `macroexp'. + (byte-compile-lexical-environment) + (byte-compile-current-heap-environment) + (byte-compile-current-num-closures): New variables. + (0, 178, 179, 180, 181): New byte-opcodes. + (byte-compile-lapcode): Handle stack-ref/set opcodes. Signal an + error if a delay-output placeholder is not filled in yet. + (byte-compile-file-form, byte-compile): Expand all macros with + `macroexpand-all'. + (byte-compile-file-form-defsubst, byte-compile-form): Don't expand + macros here. + (byte-compile-make-lambda-lexenv): Autoload. + (byte-compile-lambda): Initial code for handling lexically-bound + arguments and closures; doesn't work yet. + (byte-compile-closure-code-p, byte-compile-make-closure) + (byte-compile-closure): New functions. + (byte-compile-check-variable, byte-compile-dynamic-variable-op) + (byte-compile-dynamic-variable-bind) + (byte-compile-lexical-variable-ref, byte-compile-variable-set): + New functions. + (byte-compile-variable-ref): Remove second argument. Now only + handles real variable references (not setting or binding). + (byte-compile-push-unknown-constant) + (byte-compile-resolve-unknown-constant): New functions. + (byte-compile-funarg, byte-compile-funarg-2): Functions removed. + (byte-compile-function-form): Use either `byte-compile-constant' + or `byte-compile-closure'. + (byte-compile-setq): Use `byte-compile-variable-set' instead of + `byte-compile-variable-ref'. + (apply, mapcar, mapatoms, mapconcat, mapc, sort): + `byte-defop-compiler-1's removed. + (byte-compile-while): Make sure lexically-bound variables inside + the loop don't get stored in an environment outside the loop. + (byte-compile-compute-lforminfo): Autoload. + (byte-compile-push-binding-init): New function. + (byte-compile-let, byte-compile-let*): Handle lexical binding. + (byte-compile-defun): Use `byte-compile-closure' to do the work. + (byte-compile-defmacro): Use `byte-compile-make-closure'. + (byte-compile-defvar): Expand the generated call to `push' since + we're past macroexpansion already. + (byte-compile-stack-adjustment): New function. + (byte-compile-out): Make second arg optional. Rewrite for clarity. + (byte-compile-delay-out, byte-compile-delayed-out): New functions. + + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't + expand macros here. + + * emacs-lisp/macroexp.el (macroexpand-all-1): Expand defmacro forms. + + * emacs-lisp/byte-lexbind.el (byte-compile-make-lvarinfo) + (byte-compile-lforminfo-add-var) + (byte-compile-lforminfo-note-closure) + (byte-compile-compute-lforminfo) + (byte-compile-lforminfo-from-lambda) + (byte-compile-lforminfo-analyze) + (byte-compile-heapenv-add-accessible-env) + (byte-compile-heapenv-ensure-access) + (byte-compile-rearrange-let-clauses, byte-compile-bind) + (byte-compile-unbind): Fix a bunch of typos. + +2002-06-12 Miles Bader + + * emacs-lisp/byte-lexbind.el, emacs-lisp/macroexp.el: New files. + + * subr.el (functionp): Function removed (now a subr). + * help-fns.el (describe-function-1): Handle interpreted closures. + +;; arch-tag: bd1b5b8b-fdb2-425d-9ac2-20689fb0ee70 diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 4effdddff6..25f7b89c9d 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -71,6 +71,13 @@ AUTOGENEL = loaddefs.el \ cedet/ede/loaddefs.el \ 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 = 1000 +BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" + # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. @@ -195,7 +202,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 -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE) + @$(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE) # Files MUST be compiled one by one. If we compile several files in a # row (i.e., in the same instance of Emacs) we can't make sure that diff --git a/lisp/emacs-lisp/byte-lexbind.el b/lisp/emacs-lisp/byte-lexbind.el new file mode 100644 index 0000000000..a01829abf5 --- /dev/null +++ b/lisp/emacs-lisp/byte-lexbind.el @@ -0,0 +1,696 @@ +;;; byte-lexbind.el --- Lexical binding support for byte-compiler +;; +;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. +;; +;; Author: Miles Bader +;; Keywords: lisp, compiler, lexical binding + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; + +;;; Code: + +(require 'bytecomp-preload "bytecomp") + +;; Downward closures aren't implemented yet, so this should always be nil +(defconst byte-compile-use-downward-closures nil + "If true, use `downward closures', which are closures that don't cons.") + +(defconst byte-compile-save-window-excursion-uses-eval t + "If true, the bytecode for `save-window-excursion' uses eval. +This means that the body of the form must be put into a closure.") + +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + + +;;; Variable extent analysis. + +;; A `lforminfo' holds information about lexical bindings in a form, and some +;; other info for analysis. It is a cons-cell, where the car is a list of +;; `lvarinfo' stuctures, which form an alist indexed by variable name, and the +;; cdr is the number of closures found in the form: +;; +;; LFORMINFO : ((LVARINFO ...) . NUM-CLOSURES)" +;; +;; A `lvarinfo' holds information about a single lexical variable. It is a +;; list whose car is the variable name (so an lvarinfo is suitable as an alist +;; entry), and the rest of the of which holds information about the variable: +;; +;; LVARINFO : (VAR NUM-REFS NUM-SETS CLOSED-OVER) +;; +;; NUM-REFS is the number of times the variable's value is used +;; NUM-SETS is the number of times the variable's value is set +;; CLOSED-OVER is non-nil if the variable is referenced +;; anywhere but in its original function-level" + +;;; lvarinfo: + +;; constructor +(defsubst byte-compile-make-lvarinfo (var &optional already-set) + (list var 0 (if already-set 1 0) 0 nil)) +;; accessors +(defsubst byte-compile-lvarinfo-var (vinfo) (car vinfo)) +(defsubst byte-compile-lvarinfo-num-refs (vinfo) (cadr vinfo)) +(defsubst byte-compile-lvarinfo-num-sets (vinfo) (nth 3 vinfo)) +(defsubst byte-compile-lvarinfo-closed-over-p (vinfo) (nth 4 vinfo)) +;; setters +(defsubst byte-compile-lvarinfo-note-ref (vinfo) + (setcar (cdr vinfo) (1+ (cadr vinfo)))) +(defsubst byte-compile-lvarinfo-note-set (vinfo) + (setcar (cddr vinfo) (1+ (nth 3 vinfo)))) +(defsubst byte-compile-lvarinfo-note-closure (vinfo) + (setcar (nthcdr 4 vinfo) t)) + +;;; lforminfo: + +;; constructor +(defsubst byte-compile-make-lforminfo () + (cons nil 0)) +;; accessors +(defalias 'byte-compile-lforminfo-vars 'car) +(defalias 'byte-compile-lforminfo-num-closures 'cdr) +;; setters +(defsubst byte-compile-lforminfo-add-var (finfo var &optional already-set) + (setcar finfo (cons (byte-compile-make-lvarinfo var already-set) + (car finfo)))) + +(defun byte-compile-lforminfo-make-closure-flag () + "Return a new `closure-flag'." + (cons nil nil)) + +(defsubst byte-compile-lforminfo-note-closure (lforminfo lvarinfo closure-flag) + "If a variable reference or definition is inside a closure, record that fact. +LFORMINFO describes the form currently being analyzed, and LVARINFO +describes the variable. CLOSURE-FLAG is either nil, if currently _not_ +inside a closure, and otherwise a `closure flag' returned by +`byte-compile-lforminfo-make-closure-flag'." + (when closure-flag + (byte-compile-lvarinfo-note-closure lvarinfo) + (unless (car closure-flag) + (setcdr lforminfo (1+ (cdr lforminfo))) + (setcar closure-flag t)))) + +(defun byte-compile-compute-lforminfo (form &optional special) + "Return information about variables lexically bound by FORM. +SPECIAL is a list of variables that are special, and so shouldn't be +bound lexically (in addition to variable that are considered special +because they are declared with `defvar', et al). + +The result is an `lforminfo' data structure." + (and + (consp form) + (let ((lforminfo (byte-compile-make-lforminfo))) + (cond ((eq (car form) 'let) + ;; Find the bound variables + (dolist (clause (cadr form)) + (let ((var (if (consp clause) (car clause) clause))) + (unless (or (specialp var) (memq var special)) + (byte-compile-lforminfo-add-var lforminfo var t)))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + special nil))) + ((eq (car form) 'let*) + (dolist (clause (cadr form)) + (let ((var (if (consp clause) (car clause) clause))) + ;; Analyze each initializer based on the previously + ;; bound variables. + (when (and (consp clause) lforminfo) + (byte-compile-lforminfo-analyze lforminfo (cadr clause) + special nil)) + (unless (or (specialp var) (memq var special)) + (byte-compile-lforminfo-add-var lforminfo var t)))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + special nil))) + ((eq (car form) 'condition-case) + ;; `condition-case' currently must dynamically bind the + ;; error variable, so do nothing. + ) + ((memq (car form) '(defun defmacro)) + (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special)) + ((eq (car form) 'lambda) + (byte-compile-lforminfo-from-lambda lforminfo form special)) + ((and (consp (car form)) (eq (caar form) 'lambda)) + ;; An embedded lambda, which is basically just a `let' + (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special))) + (if (byte-compile-lforminfo-vars lforminfo) + lforminfo + nil)))) + +(defun byte-compile-lforminfo-from-lambda (lforminfo lambda special) + "Initialize LFORMINFO from the lambda expression LAMBDA. +SPECIAL is a list of variables to ignore. +The first element of LAMBDA is ignored; it need not actually be `lambda'." + ;; Add the arguments + (dolist (arg (byte-compile-arglist-vars (cadr lambda))) + (byte-compile-lforminfo-add-var lforminfo arg t)) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo lambda 2 special nil))) + +(defun byte-compile-lforminfo-analyze (lforminfo form &optional ignore closure-flag) + "Update variable information in LFORMINFO by analyzing FORM. +IGNORE is a list of variables that shouldn't be analyzed (usually because +they're special, or because some inner binding shadows the version in +LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created +with `byte-compile-lforminfo-make-closure-flag'; the latter indicates that +FORM is inside a lambda expression that may close over some variable in +LFORMINFO." + (cond ((symbolp form) + ;; variable reference + (unless (member form ignore) + (let ((vinfo (assq form (byte-compile-lforminfo-vars lforminfo)))) + (when vinfo + (byte-compile-lvarinfo-note-ref vinfo) + (byte-compile-lforminfo-note-closure lforminfo vinfo + closure-flag))))) + ;; function call/special form + ((consp form) + (let ((fun (car form))) + (cond + ((eq fun 'setq) + (pop form) + (while form + (let ((var (pop form))) + (byte-compile-lforminfo-analyze lforminfo (pop form) + ignore closure-flag) + (unless (member var ignore) + (let ((vinfo + (assq var (byte-compile-lforminfo-vars lforminfo)))) + (when vinfo + (byte-compile-lvarinfo-note-set vinfo) + (byte-compile-lforminfo-note-closure lforminfo vinfo + closure-flag))))))) + ((eq fun 'catch) + ;; tag + (byte-compile-lforminfo-analyze lforminfo (cadr form) + ignore closure-flag) + ;; `catch' uses a closure for the body + (byte-compile-lforminfo-analyze-forms + lforminfo form 2 + ignore + (or closure-flag + (and (not byte-compile-use-downward-closures) + (byte-compile-lforminfo-make-closure-flag))))) + ((eq fun 'cond) + (byte-compile-lforminfo-analyze-clauses lforminfo (cdr form) 0 + ignore closure-flag)) + ((eq fun 'condition-case) + ;; `condition-case' separates its body/handlers into + ;; separate closures. + (unless (or closure-flag byte-compile-use-downward-closures) + ;; condition case is implemented by calling a function + (setq closure-flag (byte-compile-lforminfo-make-closure-flag))) + ;; value form + (byte-compile-lforminfo-analyze lforminfo (nth 2 form) + ignore closure-flag) + ;; the error variable is always bound dynamically (because + ;; of the implementation) + (when (cadr form) + (push (cadr form) ignore)) + ;; handlers + (byte-compile-lforminfo-analyze-clauses lforminfo + (nthcdr 2 form) 1 + ignore closure-flag)) + ((eq fun '(defvar defconst)) + (byte-compile-lforminfo-analyze lforminfo (nth 2 form) + ignore closure-flag)) + ((memq fun '(defun defmacro)) + (byte-compile-lforminfo-analyze-forms lforminfo form 3 + ignore closure-flag)) + ((eq fun 'function) + ;; Analyze an embedded lambda expression [note: we only recognize + ;; it within (function ...) as the (lambda ...) for is actually a + ;; macro returning (function (lambda ...))]. + (when (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) + ;; shadow bound variables + (setq ignore + (append (byte-compile-arglist-vars (cadr (cadr form))) + ignore)) + ;; analyze body of lambda + (byte-compile-lforminfo-analyze-forms + lforminfo (cadr form) 2 + ignore + (or closure-flag + (byte-compile-lforminfo-make-closure-flag))))) + ((eq fun 'let) + ;; analyze variable inits + (byte-compile-lforminfo-analyze-clauses lforminfo (cadr form) 1 + ignore closure-flag) + ;; shadow bound variables + (dolist (clause (cadr form)) + (push (if (symbolp clause) clause (car clause)) + ignore)) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag)) + ((eq fun 'let*) + (dolist (clause (cadr form)) + (if (symbolp clause) + ;; shadow bound (to nil) variable + (push clause ignore) + ;; analyze variable init + (byte-compile-lforminfo-analyze lforminfo (cadr clause) + ignore closure-flag) + ;; shadow bound variable + (push (car clause) ignore))) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag)) + ((eq fun 'quote) + ;; do nothing + ) + ((eq fun 'save-window-excursion) + ;; `save-window-excursion' currently uses a funny implementation + ;; that requires its body forms be put into a closure (it should + ;; be fixed to work more like `save-excursion' etc., do). + (byte-compile-lforminfo-analyze-forms + lforminfo form 2 + ignore + (or closure-flag + (and byte-compile-save-window-excursion-uses-eval + (not byte-compile-use-downward-closures) + (byte-compile-lforminfo-make-closure-flag))))) + ((and (consp fun) (eq (car fun) 'lambda)) + ;; Embedded lambda. These are inlined by the compiler, so + ;; we don't treat them like a real closure, more like `let'. + ;; analyze inits + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag) + + ;; shadow bound variables + (setq ignore (nconc (byte-compile-arglist-vars (cadr fun)) + ignore)) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo fun 2 + ignore closure-flag)) + (t + ;; For everything else, we just expand each argument (for + ;; setq/setq-default this works alright because the + ;; variable names are symbols). + (byte-compile-lforminfo-analyze-forms lforminfo form 1 + ignore closure-flag))))))) + +(defun byte-compile-lforminfo-analyze-forms + (lforminfo forms skip ignore closure-flag) + "Update variable information in LFORMINFO by analyzing each form in FORMS. +The first SKIP elements of FORMS are skipped without analysis. IGNORE +is a list of variables that shouldn't be analyzed (usually because +they're special, or because some inner binding shadows the version in +LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created with +`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is +inside a lambda expression that may close over some variable in LFORMINFO." + (when skip + (setq forms (nthcdr skip forms))) + (while forms + (byte-compile-lforminfo-analyze lforminfo (pop forms) + ignore closure-flag))) + +(defun byte-compile-lforminfo-analyze-clauses + (lforminfo clauses skip ignore closure-flag) + "Update variable information in LFORMINFO by analyzing each clause in CLAUSES. +Each clause is a list of forms; any clause that's not a list is ignored. The +first SKIP elements of each clause are skipped without analysis. IGNORE is a +list of variables that shouldn't be analyzed (usually because they're special, +or because some inner binding shadows the version in LFORMINFO). +CLOSURE-FLAG should be either nil or a `closure flag' created with +`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is +inside a lambda expression that may close over some variable in LFORMINFO." + (while clauses + (let ((clause (pop clauses))) + (when (consp clause) + (byte-compile-lforminfo-analyze-forms lforminfo clause skip + ignore closure-flag))))) + + +;;; Lexical environments + +;; A lexical environment is an alist, where each element is of the form +;; (VAR . (OFFSET . ENV)) where VAR is either a symbol, for normal +;; variables, or an `heapenv' descriptor for references to heap environment +;; vectors. ENV is either an atom, meaning a `stack allocated' variable +;; (the particular atom serves to indicate the particular function context +;; on whose stack it's allocated), or an `heapenv' descriptor (see above), +;; meaning a variable allocated in a heap environment vector. For the +;; later case, an anonymous `variable' holding a pointer to the environment +;; vector may be located by recursively looking up ENV in the environment +;; as if it were a variable (so the entry for that `variable' will have a +;; non-symbol VAR). + +;; We call a lexical environment a `lexenv', and an entry in it a `lexvar'. + +;; constructor +(defsubst byte-compile-make-lexvar (name offset &optional env) + (cons name (cons offset env))) +;; accessors +(defsubst byte-compile-lexvar-name (lexvar) (car lexvar)) +(defsubst byte-compile-lexvar-offset (lexvar) (cadr lexvar)) +(defsubst byte-compile-lexvar-environment (lexvar) (cddr lexvar)) +(defsubst byte-compile-lexvar-variable-p (lexvar) (symbolp (car lexvar))) +(defsubst byte-compile-lexvar-environment-p (lexvar) + (not (symbolp (car lexvar)))) +(defsubst byte-compile-lexvar-on-stack-p (lexvar) + (atom (byte-compile-lexvar-environment lexvar))) +(defsubst byte-compile-lexvar-in-heap-p (lexvar) + (not (byte-compile-lexvar-on-stack-p lexvar))) + +(defun byte-compile-make-lambda-lexenv (form closed-over-lexenv) + "Return a new lexical environment for a lambda expression FORM. +CLOSED-OVER-LEXENV is the lexical environment in which FORM occurs. +The returned lexical environment contains two sets of variables: + * Variables that were in CLOSED-OVER-LEXENV and used by FORM + (all of these will be `heap' variables) + * Arguments to FORM (all of these will be `stack' variables)." + ;; See if this is a closure or not + (let ((closure nil) + (lforminfo (byte-compile-make-lforminfo)) + (args (byte-compile-arglist-vars (cadr form)))) + ;; Add variables from surrounding lexical environment to analysis set + (dolist (lexvar closed-over-lexenv) + (when (and (byte-compile-lexvar-in-heap-p lexvar) + (not (memq (car lexvar) args))) + ;; The variable is located in a heap-allocated environment + ;; vector, so FORM may use it. Add it to the set of variables + ;; that we'll search for in FORM. + (byte-compile-lforminfo-add-var lforminfo (car lexvar)))) + ;; See how FORM uses these potentially closed-over variables. + (byte-compile-lforminfo-analyze lforminfo form args) + (let ((lexenv nil)) + (dolist (vinfo (byte-compile-lforminfo-vars lforminfo)) + (when (> (byte-compile-lvarinfo-num-refs vinfo) 0) + ;; FORM uses VINFO's variable, so it must be a closure. + (setq closure t) + ;; Make sure that the environment in which the variable is + ;; located is accessible (since we only ever pass the + ;; innermost environment to closures, if it's in some other + ;; envionment, there must be path to it from the innermost + ;; one). + (unless (byte-compile-lexvar-in-heap-p vinfo) + ;; To access the variable from FORM, it must be in the heap. + (error + "Compiler error: lexical variable `%s' should be heap-allocated but is not" + (car vinfo))) + (let ((closed-over-lexvar (assq (car vinfo) closed-over-lexenv))) + (byte-compile-heapenv-ensure-access + byte-compile-current-heap-environment + (byte-compile-lexvar-environment closed-over-lexvar)) + ;; Put this variable in the new lexical environment + (push closed-over-lexvar lexenv)))) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + (when closure + ;; Add the magic first argument that holds the environment pointer + (push (byte-compile-make-lexvar byte-compile-current-heap-environment + 0) + lexenv) + (setq stackpos (1+ stackpos))) + ;; Add entries for each argument + (dolist (arg args) + (push (byte-compile-make-lexvar arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + +(defun byte-compile-closure-initial-lexenv-p (lexenv) + "Return non-nil if LEXENV is the initial lexical environment for a closure. +This only works correctly when passed a new lexical environment as +returned by `byte-compile-make-lambda-lexenv' (it works by checking to +see whether there are any heap-allocated lexical variables in LEXENV)." + (let ((closure nil)) + (while (and lexenv (not closure)) + (when (byte-compile-lexvar-environment-p (pop lexenv)) + (setq closure t))) + closure)) + + +;;; Heap environment vectors + +;; A `heap environment vector' is heap-allocated vector used to store +;; variable that can't be put onto the stack. +;; +;; They are represented in the compiler by a list of the form +;; +;; (SIZE SIZE-CONST-ID INIT-POSITION . ENVS) +;; +;; SIZE is the current size of the vector (which may be +;; incremented if another variable or environment-reference is added to +;; the end). SIZE-CONST-ID is an `unknown constant id' (as returned by +;; `byte-compile-push-unknown-constant') representing the constant used +;; in the vector initialization code, and INIT-POSITION is a position +;; in the byte-code output (as returned by `byte-compile-delay-out') +;; at which more initialization code can be added. +;; ENVS is a list of other environment vectors accessible form this one, +;; where each element is of the form (ENV . OFFSET). + +;; constructor +(defsubst byte-compile-make-heapenv (size-const-id init-position) + (list 0 size-const-id init-position)) +;; accessors +(defsubst byte-compile-heapenv-size (heapenv) (car heapenv)) +(defsubst byte-compile-heapenv-size-const-id (heapenv) (cadr heapenv)) +(defsubst byte-compile-heapenv-init-position (heapenv) (nth 2 heapenv)) +(defsubst byte-compile-heapenv-accessible-envs (heapenv) (nthcdr 3 heapenv)) + +(defun byte-compile-heapenv-add-slot (heapenv) + "Add a slot to the heap environment HEAPENV and return its offset." + (prog1 (car heapenv) (setcar heapenv (1+ (car heapenv))))) + +(defun byte-compile-heapenv-add-accessible-env (heapenv env offset) + "Add to HEAPENV's list of accessible environments, ENV at OFFSET." + (setcdr (nthcdr 2 heapenv) + (cons (cons env offset) + (byte-compile-heapenv-accessible-envs heapenv)))) + +(defun byte-compile-push-heapenv () + "Generate byte-code to push a new heap environment vector. +Sets `byte-compile-current-heap-environment' to the compiler descriptor +for the new heap environment. +Return a `lexvar' descriptor for the new heap environment." + (let ((env-stack-pos byte-compile-depth) + size-const-id init-position) + ;; Generate code to push the vector + (byte-compile-push-constant 'make-vector) + (setq size-const-id (byte-compile-push-unknown-constant)) + (byte-compile-push-constant nil) + (byte-compile-out 'byte-call 2) + (setq init-position (byte-compile-delay-out 3)) + ;; Now make a heap-environment for the compiler to use + (setq byte-compile-current-heap-environment + (byte-compile-make-heapenv size-const-id init-position)) + (byte-compile-make-lexvar byte-compile-current-heap-environment + env-stack-pos))) + +(defun byte-compile-heapenv-ensure-access (heapenv other-heapenv) + "Make sure that HEAPENV can be used to access OTHER-HEAPENV. +If not, then add a new slot to HEAPENV pointing to OTHER-HEAPENV." + (unless (memq heapenv (byte-compile-heapenv-accessible-envs heapenv)) + (let ((offset (byte-compile-heapenv-add-slot heapenv))) + (byte-compile-heapenv-add-accessible-env heapenv other-heapenv offset)))) + + +;;; Variable binding/unbinding + +(defun byte-compile-non-stack-bindings-p (clauses lforminfo) + "Return non-nil if any lexical bindings in CLAUSES are not stack-allocated. +LFORMINFO should be information about lexical variables being bound." + (let ((vars (byte-compile-lforminfo-vars lforminfo))) + (or (not (= (length clauses) (length vars))) + (progn + (while (and vars clauses) + (when (byte-compile-lvarinfo-closed-over-p (pop vars)) + (setq clauses nil))) + (not clauses))))) + +(defun byte-compile-let-clauses-trivial-init-p (clauses) + "Return true if let binding CLAUSES all have a `trivial' init value. +Trivial means either a constant value, or a simple variable initialization." + (or (null clauses) + (and (or (atom (car clauses)) + (atom (cadr (car clauses))) + (eq (car (cadr (car clauses))) 'quote)) + (byte-compile-let-clauses-trivial-init-p (cdr clauses))))) + +(defun byte-compile-rearrange-let-clauses (clauses lforminfo) + "Return CLAUSES rearranged so non-stack variables come last if possible. +Care is taken to only do so when it's clear that the meaning is the same. +LFORMINFO should be information about lexical variables being bound." + ;; We currently do a very simple job by only exchanging clauses when + ;; one has a constant init, or one has a variable init and the other + ;; doesn't have a function call init (because that could change the + ;; value of the variable). This could be more clever and actually + ;; attempt to analyze which variables could possible be changed, etc. + (let ((unchanged nil) + (lex-non-stack nil) + (dynamic nil)) + (while clauses + (let* ((clause (pop clauses)) + (var (if (consp clause) (car clause) clause)) + (init (and (consp clause) (cadr clause))) + (vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (cond + ((or (and vinfo + (not (byte-compile-lvarinfo-closed-over-p vinfo))) + (not + (or (eq init nil) (eq init t) + (and (atom init) (not (symbolp init))) + (and (consp init) (eq (car init) 'quote)) + (byte-compile-let-clauses-trivial-init-p clauses)))) + (push clause unchanged)) + (vinfo + (push clause lex-non-stack)) + (t + (push clause dynamic))))) + (nconc (nreverse unchanged) (nreverse lex-non-stack) (nreverse dynamic)))) + +(defun byte-compile-maybe-push-heap-environment (&optional lforminfo) + "Push a new heap environment if necessary. +LFORMINFO should be information about lexical variables being bound. +Return a lexical environment containing only the heap vector (or +nil if nothing was pushed). +Also, `byte-compile-current-heap-environment' and +`byte-compile-current-num-closures' are updated to reflect any change (so they +should probably be bound by the caller to ensure that the new values have the +proper scope)." + ;; We decide whether a new heap environment is required by seeing if + ;; the number of closures inside the form described by LFORMINFO is + ;; the same as the number inside the binding form that created the + ;; currently active heap environment. + (let ((nclosures + (and lforminfo (byte-compile-lforminfo-num-closures lforminfo)))) + (if (or (null lforminfo) + (= nclosures byte-compile-current-num-closures)) + ;; No need to push a heap environment. + nil + ;; Have to push one. A heap environment is really just a vector, so + ;; we emit bytecodes to create a vector. However, the size is not + ;; fixed yet (the vector can grow if subforms use it to store + ;; values, and if `access points' to parent heap environments are + ;; added), so we use `byte-compile-push-unknown-constant' to push the + ;; vector size. + (setq byte-compile-current-num-closures nclosures) + (list (byte-compile-push-heapenv))))) + +(defun byte-compile-bind (var init-lexenv &optional lforminfo) + "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack, and +LFORMINFO should be information about lexical variables being bound. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, either to move them to TOS for + ;; dynamic binding, or to put them in a non-stack environment + ;; vector. + (let ((vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (cond ((and (null vinfo) (eq var (caar init-lexenv))) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + ((null vinfo) + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil) + ((byte-compile-lvarinfo-closed-over-p vinfo) + ;; VAR is lexical, but needs to be in a + ;; heap-allocated environment. + (unless byte-compile-current-heap-environment + (error "No current heap-environment to allocate `%s' in!" var)) + (let ((init-stack-pos + ;; nil if the init value is on the top of the stack, + ;; otherwise the position of the init value on the stack. + (and (not (eq var (caar init-lexenv))) + (byte-compile-lexvar-offset (assq var init-lexenv)))) + (env-vec-pos + ;; Position of VAR in the environment vector + (byte-compile-lexvar-offset + (assq var byte-compile-lexical-environment))) + (env-vec-stack-pos + ;; Position of the the environment vector on the stack + ;; (the heap-environment must _always_ be available on + ;; the stack!) + (byte-compile-lexvar-offset + (assq byte-compile-current-heap-environment + byte-compile-lexical-environment)))) + (unless env-vec-stack-pos + (error "Couldn't find location of current heap environment!")) + (when init-stack-pos + ;; VAR is not on the top of the stack, so get it + (byte-compile-stack-ref init-stack-pos)) + (byte-compile-stack-ref env-vec-stack-pos) + ;; Store the variable into the vector + (byte-compile-out 'byte-vec-set env-vec-pos) + (when init-stack-pos + ;; Store nil into VAR's temporary stack + ;; position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set init-stack-pos)) + ;; Push a record of VAR's new lexical binding + (push (byte-compile-make-lexvar + var env-vec-pos byte-compile-current-heap-environment) + byte-compile-lexical-environment) + (not init-stack-pos))) + (t + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile-lexical-environment) + nil)))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional lforminfo preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack, and LFORMINFO should be information about +the lexical variables that were bound. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (if lforminfo + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + (byte-compile-lforminfo-vars lforminfo)) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (setq num-dynamic-bindings (length clauses))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) + + +(provide 'byte-lexbind) + +;;; arch-tag: b8f1dff6-9edb-4430-a96f-323d42a681a9 +;;; byte-lexbind.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index e461010a6c..4c0094dd78 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -186,8 +186,8 @@ (eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) +;; (if (aref byte-code-vector 0) +;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply 'format format (let (c a) @@ -281,7 +281,8 @@ (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment) ;; Give up on inlining. form)))))) @@ -1332,14 +1333,15 @@ ((>= op byte-constant) (prog1 (- op byte-constant) ;offset in opcode (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) + ((or (and (>= op byte-constant2) + (<= op byte-goto-if-not-nil-else-pop)) + (= op byte-stack-set2)) (setq ptr (1+ ptr)) ;offset in next 2 bytes (+ (aref bytes ptr) (progn (setq ptr (1+ ptr)) (lsh (aref bytes ptr) 8)))) ((and (>= op byte-listN) - (<= op byte-insertN)) + (<= op byte-discardN)) (setq ptr (1+ ptr)) ;offset in next byte (aref bytes ptr)))) @@ -1400,7 +1402,16 @@ (if (= ptr (1- length)) (setq op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) + op 'byte-goto))) + ((eq op 'byte-stack-set2) + (setq op 'byte-stack-set)) + ((and (eq op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (setq lap (cons (cons optr (cons op (or offset 0))) lap)) @@ -1456,7 +1467,7 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p)) + byte-current-buffer byte-interactive-p byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1465,7 +1476,7 @@ byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) + byte-member byte-assq byte-quo byte-rem byte-vec-ref) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1498,12 +1509,50 @@ ;; The variable `byte-boolean-vars' is now primitive and updated ;; automatically by DEFVAR_BOOL. +(defmacro byte-opt-update-stack-params (stack-adjust stack-depth lap0 rest lap) + "...macro used by byte-optimize-lapcode..." + `(progn + (byte-compile-log-lap "Before %s [depth = %s]" ,lap0 ,stack-depth) + (cond ((eq (car ,lap0) 'TAG) + ;; A tag can encode the expected stack depth. + (when (cddr ,lap0) + ;; First, check to see if our notion of the current stack + ;; depth agrees with this tag. We don't check at the + ;; beginning of the function, because the presence of + ;; lexical arguments means the first tag will have a + ;; non-zero offset. + (when (and (not (eq ,rest ,lap)) ; not at first insn + ,stack-depth ; not just after a goto + (not (= (cddr ,lap0) ,stack-depth))) + (error "Compiler error: optimizer is confused about %s: + %s != %s at lapcode %s" ',stack-depth (cddr ,lap0) ,stack-depth ,lap0)) + ;; Now set out current depth from this tag + (setq ,stack-depth (cddr ,lap0))) + (setq ,stack-adjust 0)) + ((memq (car ,lap0) '(byte-goto byte-return)) + ;; These insns leave us in an unknown state + (setq ,stack-adjust nil)) + ((car ,lap0) + ;; Not a no-op, set ,stack-adjust for lap0. ,stack-adjust will + ;; be added to ,stack-depth at the end of the loop, so any code + ;; that modifies the instruction sequence must adjust this too. + (setq ,stack-adjust + (byte-compile-stack-adjustment (car ,lap0) (cdr ,lap0))))) + (byte-compile-log-lap "Before %s [depth => %s, adj = %s]" ,lap0 ,stack-depth ,stack-adjust) + )) + (defun byte-optimize-lapcode (lap &optional for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (let (lap0 lap1 lap2 + stack-adjust + stack-depth + (initial-stack-depth + (if (and lap (eq (car (car lap)) 'TAG)) + (cdr (cdr (car lap))) + 0)) (keep-going 'first-time) (add-depth 0) rest tmp tmp2 tmp3 @@ -1514,12 +1563,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or (eq keep-going 'first-time) (byte-compile-log-lap " ---- next pass")) (setq rest lap + stack-depth initial-stack-depth keep-going nil) (while rest (setq lap0 (car rest) lap1 (nth 1 rest) lap2 (nth 2 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) + ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. @@ -1533,22 +1585,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ((and (eq 'byte-discard (car lap1)) (memq (car lap0) side-effect-free)) (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) (setq rest (cdr rest)) - (cond ((= tmp 1) + (cond ((= stack-adjust 1) (byte-compile-log-lap " %s discard\t-->\t" lap0) (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) + ((= stack-adjust 0) (byte-compile-log-lap " %s discard\t-->\t discard" lap0) (setq lap (delq lap0 lap))) - ((= tmp -1) + ((= stack-adjust -1) (byte-compile-log-lap " %s discard\t-->\tdiscard discard" lap0) (setcar lap0 'byte-discard) (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) + ((error "Optimizer error: too much on the stack"))) + (setq stack-adjust (1- stack-adjust))) ;; ;; goto*-X X: --> X: ;; @@ -1573,10 +1625,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + ((or (and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (and (eq (car lap2) 'byte-stack-ref) + (eq (car lap1) 'byte-stack-set) + (eq (cdr lap1) (cdr lap2)))) + (if (and (eq 'byte-varref (car lap2)) + (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) @@ -1608,10 +1664,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t - rest (cdr rest)) + rest (cdr rest) + stack-adjust -1) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1633,7 +1690,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." 'byte-goto-if-not-nil 'byte-goto-if-nil)) (setq lap (delq lap0 lap)) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: @@ -1649,7 +1707,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" lap0 lap1 lap2 (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) + (setq lap (delq lap0 lap) + stack-adjust 0) (setcar lap1 inverse) (setq keep-going t))) ;; @@ -1666,15 +1725,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq rest (cdr rest) lap (delq lap0 (delq lap1 lap)))) (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup @@ -1682,14 +1740,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. ;; - ((and (eq 'byte-varref (car lap0)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn - (setq tmp (cdr rest)) + (setq tmp (cdr rest) tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp (cdr tmp) tmp2 (1+ tmp2))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) + (eq (car lap0) (car (car tmp))) + (eq (cdr lap0) (cdr (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1701,7 +1759,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq keep-going t) (setcar (car tmp) 'byte-dup) (setcdr (car tmp) 0) - (setq rest tmp)) + (setq rest tmp + stack-adjust (+ 2 tmp2))) ;; ;; TAG1: TAG2: --> TAG1: ;; (and other references to TAG2 are replaced with TAG1) @@ -1768,7 +1827,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) (setcar rest lap1) (setcar (cdr rest) lap0) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; varbind-X unbind-N --> discard unbind-(N-1) ;; save-excursion unbind-N --> unbind-(N-1) @@ -1794,6 +1854,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." "")) (setq keep-going t)) ;; + ;; stack-ref-N --> dup ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-stack-ref) + (= (cdr lap0) (1- stack-depth))) + (setcar lap0 'byte-dup) + (setcdr lap0 nil) + (setq keep-going t)) + ;; ;; goto*-X ... X: goto-Y --> goto*-Y ;; goto-X ... X: return --> return ;; @@ -1870,20 +1938,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; X: varref-Y ... varset-Y goto-X --> ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). ;; - ((and (eq (car lap1) 'byte-varset) + ((and (memq (car lap1) '(byte-varset byte-stack-set)) (eq (car lap2) 'byte-goto) (not (memq (cdr lap2) rest)) ;Backwards jump (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) + (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) + (not (and (eq (car lap1) 'byte-varref) + (memq (car (cdr lap1)) byte-boolean-vars)))) ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) (let ((newtag (byte-compile-make-tag))) (byte-compile-log-lap @@ -1940,10 +2010,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-goto-if-not-nil byte-goto byte-goto)))) ) - (setq keep-going t)) + (setq keep-going t + stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1))) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) ) + ;; Cleanup stage: ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they @@ -1951,10 +2026,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) - (setq rest lap) + (setq rest lap + stack-depth initial-stack-depth) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) (if (memq (car lap0) byte-constref-ops) (if (or (eq (car lap0) 'byte-constant) (eq (car lap0) 'byte-constant2)) @@ -2001,11 +2079,108 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-unbind (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (- stack-depth 2 (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (if (eq (car (car tmp)) 'byte-discard) + (setq tmp3 (1+ tmp3)) + (setq tmp3 (+ tmp3 (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization + (setq lap (delq lap0 lap)) + (cond ((= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more value + ;; (to get rid of the old value) using the TOS-preserving + ;; discard operator. + (setcar lap1 'byte-discardN-preserve-tos) + (setcdr lap1 (1+ tmp3))) + (t + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + (setcar lap1 'byte-discardN) + (setcdr lap1 tmp3))) + (setcdr (cdr rest) tmp) + (setq stack-adjust 0) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard + byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN) + (setq stack-adjust 0)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) (- stack-depth 2))))) + ;; the byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it + (setq lap (delq lap0 lap)) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; dup stack-set-N return --> return ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-dup) + (eq (car lap1) 'byte-stack-set) + (eq (car (car (cdr (cdr rest)))) 'byte-return) + (= (cdr lap1) (1- stack-depth))) + (setq lap (delq lap0 (delq lap1 lap))) + (setq rest (cdr rest)) + (setq stack-adjust 0) + (byte-compile-log-lap " dup %s return\t-->\treturn" lap1)) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 217afea9f8..c80bcd49b8 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -116,12 +116,55 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) +(require 'macroexp) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (load "byte-run")) +;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation +;; errors; however that file also wants to do (require 'bytecomp) for the +;; same reason. Since we know it's OK to load byte-lexbind.el second, we +;; have that file require a feature that's provided before at the beginning +;; of this file, to avoid an infinite require loop. +;; `eval-when-compile' is defined in byte-run.el, so it must come after the +;; preceding load expression. +(provide 'bytecomp-preload) +(eval-when-compile (require 'byte-lexbind)) + +;; The feature of compiling in a specific target Emacs version +;; has been turned off because compile time options are a bad idea. +(defmacro byte-compile-single-version () nil) +(defmacro byte-compile-version-cond (cond) cond) + +;; The crud you see scattered through this file of the form +;; (or (and (boundp 'epoch::version) epoch::version) +;; (string-lessp emacs-version "19")) +;; is because the Epoch folks couldn't be bothered to follow the +;; normal emacs version numbering convention. + +;; (if (byte-compile-version-cond +;; (or (and (boundp 'epoch::version) epoch::version) +;; (string-lessp emacs-version "19"))) +;; (progn +;; ;; emacs-18 compatibility. +;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined +;; +;; (if (byte-compile-single-version) +;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil) +;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil)) +;; +;; (or (and (fboundp 'member) +;; ;; avoid using someone else's possibly bogus definition of this. +;; (subrp (symbol-function 'member))) +;; (defun member (elt list) +;; "like memq, but uses equal instead of eq. In v19, this is a subr." +;; (while (and list (not (equal elt (car list)))) +;; (setq list (cdr list))) +;; list)))) + + (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -398,7 +441,17 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -(defvar byte-compile-debug nil) +;(defvar byte-compile-debug nil) +(defvar byte-compile-debug t) + +;; (defvar byte-compile-overwrite-file t +;; "If nil, old .elc files are deleted before the new is saved, and .elc +;; files will have the same modes as the corresponding .el file. Otherwise, +;; existing .elc files will simply be overwritten, and the existing modes +;; will not be changed. If this variable is nil, then an .elc file which +;; is a symbolic link will be turned into a normal file, instead of the file +;; which the link points to being overwritten.") + (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil @@ -418,11 +471,18 @@ This list lives partly on the stack.") ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) - (byte-compile-eval-before-compile (cons 'progn body)) + (byte-compile-eval-before-compile + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)) (cons 'progn body)))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when @@ -453,6 +513,14 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile-lexical-environment nil + "The current lexical environment.") +(defvar byte-compile-current-heap-environment nil + "If non-nil, a descriptor for the current heap-allocated lexical environment.") +(defvar byte-compile-current-num-closures 0 + "The number of lexical closures that close over `byte-compile-current-heap-environment'.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -498,11 +566,10 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; unused: 0-7 - ;; These opcodes are special in that they pack their argument into the ;; opcode word. ;; +(byte-defop 0 1 byte-stack-ref "for stack reference") (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -664,11 +731,28 @@ otherwise pop it") (byte-defop 168 0 byte-integerp) ;; unused: 169-174 + (byte-defop 175 nil byte-listN) (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte +(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes +(byte-defop 180 1 byte-vec-ref) ; vector offset in following one byte +(byte-defop 181 -1 byte-vec-set) ; vector offset in following one byte + +;; 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 +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -715,71 +799,108 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(cons ,@byte-exprs ,bytes-var) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaulated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (defun byte-compile-lapcode (lap) "Turns lapcode into bytecode. The lapcode is destroyed." ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. (let ((pc 0) ; Program counter op off ; Operation & offset + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) (cond ((not (symbolp op)) (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) + (setcar off pc)) + ((null op) + ;; a no-op added by `byte-compile-delay-out' + (unless (zerop off) + (error + "Placeholder added by `byte-compile-delay-out' not filled in.") + )) (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a psuedo op, which is actually + ;; the same as byte-discardN with a modified argument + (setq opcode byte-discardN) + (setq opcode (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; 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))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is wierd in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + + ;; Patch tag PCs into absolute jumps + (dolist (bytes-tail patchlist) + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag + (setcar (cdr bytes-tail) (logand pc 255)) + (setcar bytes-tail (lsh pc -8)) + ;; FIXME: Replace this by some workaround. + (if (> (car bytes) 255) (error "Bytecode overflow"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -2073,18 +2194,16 @@ list that represents a doc string reference. (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) + (setq form (macroexpand-all form byte-compile-macro-environment)) + (cond ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall bytecomp-handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, ;; so make-docfile can recognise them. Most other things can be output @@ -2096,8 +2215,7 @@ list that represents a doc string reference. (setq byte-compile-current-form (nth 1 form)) (byte-compile-warn "defsubst `%s' was used before it was defined" (nth 1 form))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) + (byte-compile-file-form form) ;; Return nil so the form is not output twice. nil) @@ -2418,6 +2536,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) + ;; expand macros + (setq fun + (macroexpand-all fun + byte-compile-initial-macro-environment)) + ;; get rid of the `function' quote added by the `lambda' macro + (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2505,6 +2629,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) +(autoload 'byte-compile-make-lambda-lexenv "byte-lexbind") + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2561,20 +2687,43 @@ 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))) + (let* ((byte-compile-lexical-environment + ;; If doing lexical binding, push a new lexical environment + ;; containing the args and any closed-over variables. + (and lexical-binding + (byte-compile-make-lambda-lexenv + fun + byte-compile-lexical-environment))) + (is-closure + ;; This is true if we should be making a closure instead of + ;; a simple lambda (because some variables from the + ;; containing lexical environment are closed over). + (and lexical-binding + (byte-compile-closure-initial-lexenv-p + byte-compile-lexical-environment))) + (byte-compile-current-heap-environment nil) + (byte-compile-current-num-closures 0) + (compiled + (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) + (let ((code + (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 is-closure + (cons 'closure code) + code)) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) @@ -2585,6 +2734,26 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list nil)))) compiled)))))) +(defun byte-compile-closure-code-p (code) + (eq (car-safe code) 'closure)) + +(defun byte-compile-make-closure (code) + ;; A real closure requires that the constant be curried with an + ;; environment vector to make a closure object. + (if for-effect + (setq for-effect nil) + (byte-compile-push-constant 'curry) + (byte-compile-push-constant code) + (byte-compile-lexical-variable-ref byte-compile-current-heap-environment) + (byte-compile-out 'byte-call 2))) + +(defun byte-compile-closure (form &optional add-lambda) + (let ((code (byte-compile-lambda form add-lambda))) + (if (byte-compile-closure-code-p code) + (byte-compile-make-closure code) + ;; A simple lambda is just a constant + (byte-compile-constant code)))) + (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). @@ -2629,17 +2798,51 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + ;; Set up things for a lexically-bound function + (when (and lexical-binding (eq output-type 'lambda)) + ;; See how many arguments there are, and set the current stack depth + ;; accordingly + (dolist (var byte-compile-lexical-environment) + (when (byte-compile-lexvar-on-stack-p var) + (setq byte-compile-depth (1+ byte-compile-depth)))) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag))) + ;; If this is the top-level of a lexically bound lambda expression, + ;; perhaps some parameters on stack need to be copied into a heap + ;; environment, so check for them, and do so if necessary. + (let ((lforminfo (byte-compile-make-lforminfo))) + ;; Add any lexical variable that's on the stack to the analysis set. + (dolist (var byte-compile-lexical-environment) + (when (byte-compile-lexvar-on-stack-p var) + (byte-compile-lforminfo-add-var lforminfo (car var) t))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze lforminfo form nil nil)) + ;; If the analysis revealed some argument need to be in a heap + ;; environment (because they're closed over by an embedded + ;; lambda), put them there. + (setq byte-compile-lexical-environment + (nconc (byte-compile-maybe-push-heap-environment lforminfo) + byte-compile-lexical-environment)) + (dolist (arginfo (byte-compile-lforminfo-vars lforminfo)) + (when (byte-compile-lvarinfo-closed-over-p arginfo) + (byte-compile-bind (car arginfo) + byte-compile-lexical-environment + lforminfo))))) + ;; Now compile FORM + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2761,7 +2964,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) (when (symbolp form) @@ -2771,7 +2973,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (byte-compile-set-symbol-position form)) (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) + (t + (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((bytecomp-fn (car form)) (bytecomp-handler (get bytecomp-fn 'byte-compile))) @@ -2822,44 +3025,98 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") - ((eq base-op 'byte-varset) "variable assignment to %s `%s'") - (t "variable reference to %s `%s'")) - (if (symbolp bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) +(defun byte-compile-check-variable (var &optional binding) + "Do various error checks before a use of the variable VAR. +If BINDING is non-nil, VAR is being bound." + (when (symbolp var) + (byte-compile-set-symbol-position var)) + (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (when (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn (if binding + "attempt to let-bind %s `%s`" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) + ((and (get var 'byte-obsolete-variable) + (not (eq var byte-compile-not-obsolete-var))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(defun byte-compile-dynamic-variable-bind (var) + "Generate code to bind the lexical variable VAR to the top-of-stack value." + (byte-compile-check-variable var t) + (when (byte-compile-warning-enabled-p 'free-vars) + (push var byte-compile-bound-variables)) + (byte-compile-dynamic-variable-op 'byte-varbind var)) + +;; This is used when it's know that VAR _definitely_ has a lexical +;; binding, and no error-checking should be done. +(defun byte-compile-lexical-variable-ref (var) + "Generate code to push the value of the lexical variable VAR on the stack." + (let ((binding (assq var byte-compile-lexical-environment))) + (when (null binding) + (error "Lexical binding not found for `%s'" var)) + (if (byte-compile-lexvar-on-stack-p binding) + ;; On the stack + (byte-compile-stack-ref (byte-compile-lexvar-offset binding)) + ;; In a heap environment vector; first push the vector on the stack + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment binding)) + ;; Now get the value from it + (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding))))) + +(defun byte-compile-variable-ref (var) + "Generate code to push the value of the variable VAR on the stack." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (if (byte-compile-lexvar-on-stack-p lex-binding) + ;; On the stack + (byte-compile-stack-ref (byte-compile-lexvar-offset lex-binding)) + ;; In a heap environment vector + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment lex-binding)) + (byte-compile-out 'byte-vec-ref + (byte-compile-lexvar-offset lex-binding))) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "reference to free variable `%s'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(defun byte-compile-variable-set (var) + "Generate code to set the variable VAR from the top-of-stack value." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (if (byte-compile-lexvar-on-stack-p lex-binding) + ;; On the stack + (byte-compile-stack-set (byte-compile-lexvar-offset lex-binding)) + ;; In a heap environment vector + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment lex-binding)) + (byte-compile-out 'byte-vec-set + (byte-compile-lexvar-offset lex-binding))) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2886,6 +3143,25 @@ That command is designed for interactive use only" bytecomp-fn)) (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. @@ -3089,8 +3365,39 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-noop (form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack (NUM defaults to 1). +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(defun byte-compile-stack-ref (stack-pos) + "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." + (if (= byte-compile-depth (1+ stack-pos)) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref stack-pos))) + +(defun byte-compile-stack-set (stack-pos) + "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." + (byte-compile-out 'byte-stack-set stack-pos)) ;; Compile a function that accepts one or more args and is right-associative. @@ -3249,40 +3556,14 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" the syntax (function (lambda (...) ...)) instead."))))) (byte-compile-two-args form)) -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (if (symbolp (nth 1 form)) + (byte-compile-constant (nth 1 form)) + (byte-compile-closure (nth 1 form)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3326,7 +3607,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (car (cdr bytecomp-args))) (or for-effect (cdr (cdr bytecomp-args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) + (byte-compile-variable-set (car bytecomp-args)) (setq bytecomp-args (cdr (cdr bytecomp-args)))) ;; (setq), with no arguments. (byte-compile-form nil for-effect)) @@ -3392,16 +3673,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 or) (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) (byte-defop-compiler-1 let*) @@ -3583,7 +3854,14 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-while (form) (let ((endtag (byte-compile-make-tag)) - (looptag (byte-compile-make-tag))) + (looptag (byte-compile-make-tag)) + ;; Heap environments can't be shared between a loop and its + ;; enclosing environment (because any lexical variables bound + ;; inside the loop should have an independent value for each + ;; iteration). Setting `byte-compile-current-num-closures' to + ;; an invalid value causes the code that tries to merge + ;; environments to not do so. + (byte-compile-current-num-closures -1)) (byte-compile-out-tag looptag) (byte-compile-form (car (cdr form))) (byte-compile-goto-if nil for-effect endtag) @@ -3596,34 +3874,116 @@ that suppresses all warnings during execution of BODY." (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +;; All other lexical-binding functions are guarded by a non-nil return +;; value from `byte-compile-compute-lforminfo', so they needn't be +;; autoloaded. +(autoload 'byte-compile-compute-lforminfo "byte-lexbind") + +(defun byte-compile-push-binding-init (clause init-lexenv lforminfo) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +INIT-LEXENV is the lexical environment created for initializations +already done for this form. +LFORMINFO should be information about lexical variables being bound. +Return INIT-LEXENV updated to include the newest initialization, or nil +if LFORMINFO is nil (meaning all bindings are dynamic)." + (let* ((var (if (consp clause) (car clause) clause)) + (vinfo + (and lforminfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (unused (and vinfo (zerop (cadr vinfo))))) + (unless (and unused (symbolp clause)) + (when (and lforminfo (not unused)) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (push (byte-compile-make-lexvar var byte-compile-depth) init-lexenv)) + (if (consp clause) + (byte-compile-form (cadr clause) unused) + (byte-compile-push-constant nil)))) + init-lexenv) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (dolist (var varlist) - (if (consp var) - (byte-compile-form (car (cdr var))) - (byte-compile-push-constant nil)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (dolist (var varlist) - (byte-compile-variable-ref 'byte-varbind - (if (consp var) (car var) var))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) + (init-lexenv nil) + ;; bind these to restrict the scope of any changes + (byte-compile-current-heap-environment + byte-compile-current-heap-environment) + (byte-compile-current-num-closures byte-compile-current-num-closures)) + (when (and lforminfo (byte-compile-non-stack-bindings-p clauses lforminfo)) + ;; Some of the variables we're binding are lexical variables on + ;; the stack, but not all. As much as we can, rearrange the list + ;; so that non-stack lexical variables and dynamically bound + ;; variables come last, which allows slightly more optimal + ;; byte-code for binding them. + (setq clauses (byte-compile-rearrange-let-clauses clauses lforminfo))) + ;; If necessary, create a new heap environment to hold some of the + ;; variables bound here. + (when lforminfo + (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) + ;; First compute the binding values in the old scope. + (dolist (clause clauses) + (setq init-lexenv + (byte-compile-push-binding-init clause init-lexenv lforminfo))) + ;; Now do the bindings, execute the body, and undo the bindings + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment) + (preserve-body-value (not for-effect))) + (dolist (clause (reverse clauses)) + (let ((var (if (consp clause) (car clause) clause))) + (cond ((null lforminfo) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv lforminfo) + (pop init-lexenv))))) + ;; Emit the body + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables + (if lforminfo + ;; Unbind both lexical and dynamic variables + (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) + ;; Unbind dynamic variables + (byte-compile-out 'byte-unbind (length clauses)))))) (defun byte-compile-let* (form) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (copy-sequence (car (cdr form))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr var))) - (setq var (car var))) - (byte-compile-variable-ref 'byte-varbind var)) + "Generate code for the `let*' form FORM." + (let ((clauses (cadr form)) + (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) + (init-lexenv nil) + (preserve-body-value (not for-effect)) + ;; bind these to restrict the scope of any changes + (byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment) + (byte-compile-current-heap-environment + byte-compile-current-heap-environment) + (byte-compile-current-num-closures byte-compile-current-num-closures)) + ;; If necessary, create a new heap environment to hold some of the + ;; variables bound here. + (when lforminfo + (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) + ;; Bind the variables + (dolist (clause clauses) + (setq init-lexenv + (byte-compile-push-binding-init clause init-lexenv lforminfo)) + (let ((var (if (consp clause) (car clause) clause))) + (cond ((null lforminfo) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv lforminfo) + (pop init-lexenv))))) + ;; Emit the body (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + ;; Unbind the variables + (if lforminfo + ;; Unbind both lexical and dynamic variables + (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) + ;; Unbind dynamic variables + (byte-compile-out 'byte-unbind (length clauses))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3646,6 +4006,7 @@ that suppresses all warnings during execution of BODY." "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) + ;;; other tricky macro-like special-forms @@ -3766,28 +4127,28 @@ that suppresses all warnings during execution of BODY." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - ;; We prefer to generate a defalias form so it will record the function - ;; definition just like interpreting a defun. - (byte-compile-form - (list 'defalias - (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t))) - t) - (byte-compile-constant (nth 1 form))) + (let ((for-effect nil)) + (byte-compile-push-constant 'defalias) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-closure (cdr (cdr form)) t)) + (byte-compile-out 'byte-call 2)) (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) + ;; 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)) + (if (not (byte-compile-closure-code-p code)) + ;; simple lambda + (byte-compile-push-constant (cons 'macro code)) + (byte-compile-push-constant 'macro) + (byte-compile-make-closure code) + (byte-compile-out 'byte-cons)) + (byte-compile-out 'byte-fset) + (byte-compile-discard)) + (byte-compile-constant (nth 1 form))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -3813,7 +4174,7 @@ that suppresses all warnings during execution of BODY." ;; Put the defined variable in this library's load-history entry ;; just as a real defvar would, but only in top-level forms. (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) + `(setq current-load-list (cons ',var current-load-list))) (when (> (length form) 3) (when (and string (not (stringp string))) (byte-compile-warn "third arg to `%s %s' is not a string: %s" @@ -3935,23 +4296,74 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (cons opcode offset) byte-compile-output) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; that take OPERAND values off the stack and push a result, for + ;; a total of 1 - OPERAND + (- 1 operand)))) + +(defun byte-compile-out (op &optional operand) + (push (cons op operand) byte-compile-output) + (if (eq op 'byte-return) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) + +(defun byte-compile-delay-out (&optional stack-used stack-adjust) + "Add a placeholder to the output, which can be used to later add byte-codes. +Return a position tag that can be passed to `byte-compile-delayed-out' +to add the delayed byte-codes. STACK-USED is the maximum amount of +stack-spaced used by the delayed byte-codes (defaulting to 0), and +STACK-ADJUST is the amount by which the later-added code will adjust the +stack (defaulting to 0); the byte-codes added later _must_ adjust the +stack by this amount! If STACK-ADJUST is 0, then it's not necessary to +actually add anything later; the effect as if nothing was added at all." + ;; We just add a no-op to `byte-compile-output', and return a pointer to + ;; the tail of the list; `byte-compile-delayed-out' uses list surgery + ;; to add the byte-codes. + (when stack-used + (setq byte-compile-maxdepth + (max byte-compile-depth (+ byte-compile-depth (or stack-used 0))))) + (when stack-adjust + (setq byte-compile-depth + (+ byte-compile-depth stack-adjust))) + (push (cons nil (or stack-adjust 0)) byte-compile-output)) + +(defun byte-compile-delayed-out (position op &optional operand) + "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND. +POSITION should a position returned by `byte-compile-delay-out'. +Return a new position, which can be used to add further operations." + (unless (null (caar position)) + (error "Bad POSITION arg to `byte-compile-delayed-out'")) + ;; This is kind of like `byte-compile-out', but we splice into the list + ;; where POSITION is. We don't bother updating `byte-compile-maxdepth' + ;; because that was already done by `byte-compile-delay-out', but we do + ;; update the relative operand stored in the no-op marker currently at + ;; POSITION; since we insert before that marker, this means that if the + ;; caller doesn't insert a sequence of byte-codes that matches the expected + ;; operand passed to `byte-compile-delay-out', then the nop will still have + ;; a non-zero operand when `byte-compile-lapcode' is called, which will + ;; cause an error to be signaled. + + ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op + (setcdr (car position) + (- (cdar position) (byte-compile-stack-adjustment op operand))) + ;; Add the new operation onto the list tail at POSITION + (setcdr position (cons (cons op operand) (cdr position))) + position) ;;; call tree stuff diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9899e991e3..18aa5fde0c 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -73,19 +73,22 @@ redefine OBJECT if it is a symbol." (let ((macro 'nil) (name 'nil) (doc 'nil) + (lexical-binding nil) args) (while (symbolp obj) (setq name obj obj (symbol-function obj))) (if (subrp obj) (error "Can't disassemble #" name)) - (if (and (listp obj) (eq (car obj) 'autoload)) - (progn - (load (nth 1 obj)) - (setq obj (symbol-function name)))) + (when (and (listp obj) (eq (car obj) 'autoload)) + (load (nth 1 obj)) + (setq obj (symbol-function name))) (if (eq (car-safe obj) 'macro) ;handle macros (setq macro t obj (cdr obj))) + (when (and (listp obj) (eq (car obj) 'closure)) + (setq lexical-binding t) + (setq obj (cddr obj))) (if (and (listp obj) (eq (car obj) 'byte-code)) (setq obj (list 'lambda nil obj))) (if (and (listp obj) (not (eq (car obj) 'lambda))) @@ -216,7 +219,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (cond ((memq op byte-goto-ops) (insert (int-to-string (nth 1 arg)))) ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) + byte-listN byte-concatN byte-insertN + byte-stack-ref byte-stack-set byte-stack-set2 + byte-discardN byte-discardN-preserve-tos)) (insert (int-to-string arg))) ((memq op '(byte-varref byte-varset byte-varbind)) (prin1 (car arg) (current-buffer))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 02477baf74..1185f79806 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -701,7 +701,15 @@ If CHAR is not a character, return nil." (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) + (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) + ;; preserve the current lexical environment + (internal-interpreter-environment internal-interpreter-environment)) + ;; Setup the lexical environment if lexical-binding is enabled. + ;; Note that `internal-interpreter-environment' _can't_ be both + ;; assigned and let-bound above -- it's treated specially (and + ;; oddly) by the interpreter! + (when lexical-binding + (setq internal-interpreter-environment '(t))) (eval-last-sexp-print-value (eval (preceding-sexp))))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 86e9411b14..9a505b214c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -100,6 +100,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) + ;; and do the same for interpreted closures + (if (eq (car-safe def) 'closure) (setq def (cddr def))) (cond ((byte-code-function-p def) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) @@ -190,7 +192,7 @@ if the variable `help-downcase-arguments' is non-nil." doc t t 1))))) (defun help-highlight-arguments (usage doc &rest args) - (when usage + (when (and usage (string-match "^(" usage)) (with-temp-buffer (insert usage) (goto-char (point-min)) @@ -347,8 +349,7 @@ suitable file is found, return nil." (pt1 (with-current-buffer (help-buffer) (point))) errtype) (setq string - (cond ((or (stringp def) - (vectorp def)) + (cond ((or (stringp def) (vectorp def)) "a keyboard macro") ((subrp def) (if (eq 'unevalled (cdr (subr-arity def))) @@ -356,6 +357,13 @@ 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))) @@ -367,6 +375,8 @@ suitable file is found, return nil." (concat beg "Lisp function")) ((eq (car-safe def) 'macro) "a Lisp macro") + ((eq (car-safe def) 'closure) + (concat beg "Lisp closure")) ((eq (car-safe def) 'autoload) (format "%s autoloaded %s" (if (commandp def) "an interactive" "an") @@ -494,27 +504,42 @@ 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))) (insert (car high) "\n") - (fill-region fill-begin (point))) - (setq doc (cdr high)))) - (let* ((obsolete (and - ;; function might be a lambda construct. - (symbolp function) - (get function 'byte-obsolete-info))) - (use (car obsolete))) - (when obsolete - (princ "\nThis function is obsolete") - (when (nth 2 obsolete) - (insert (format " since %s" (nth 2 obsolete)))) - (insert (cond ((stringp use) (concat ";\n" use)) - (use (format ";\nuse `%s' instead." use)) - (t ".")) - "\n")) - (insert "\n" - (or doc "Not documented.")))))))) + (fill-region fill-begin (point)))) + (setq doc (cdr high)))) + (let* ((obsolete (and + ;; function might be a lambda construct. + (symbolp function) + (get function 'byte-obsolete-info))) + (use (car obsolete))) + (when obsolete + (princ "\nThis function is obsolete") + (when (nth 2 obsolete) + (insert (format " since %s" (nth 2 obsolete)))) + (insert (cond ((stringp use) (concat ";\n" use)) + (use (format ";\nuse `%s' instead." use)) + (t ".")) + "\n")) + (insert "\n" + (or doc "Not documented."))))))) ;; Variables diff --git a/lisp/subr.el b/lisp/subr.el index 16ba45f1c7..61a226c20f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -427,6 +427,12 @@ Non-strings in LIST are ignored." (setq list (cdr list))) list) +(defmacro with-lexical-binding (&rest body) + "Execute the statements in BODY using lexical binding." + `(let ((internal-interpreter-environment internal-interpreter-environment)) + (setq internal-interpreter-environment '(t)) + ,@body)) + (defun assq-delete-all (key alist) "Delete from ALIST all elements whose car is `eq' to KEY. Return the modified alist. diff --git a/src/ChangeLog.funvec b/src/ChangeLog.funvec new file mode 100644 index 0000000000..098539f1dd --- /dev/null +++ b/src/ChangeLog.funvec @@ -0,0 +1,37 @@ +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/ChangeLog.lexbind b/src/ChangeLog.lexbind new file mode 100644 index 0000000000..c8336d12e9 --- /dev/null +++ b/src/ChangeLog.lexbind @@ -0,0 +1,104 @@ +2008-04-23 Miles Bader + + * eval.c (Ffunctionp): Return nil for special forms. + (Qunevalled): New variable. + (syms_of_eval): Initialize it. + +2007-10-18 Miles Bader + + * eval.c (FletX): Test the type of VARLIST rather than just !NILP. + (Flet): Use XCAR instead of Fcar. + +2007-10-16 Miles Bader + + * alloc.c (make_funvec, Fpurecopy): Set the pseudo-vector type. + +2006-02-10 Miles Bader + + * eval.c (Ffunctionp): Supply new 2nd arg to Findirect_function. + +2005-03-04 Miles Bader + + * eval.c (FletX): Update Vinterpreter_lexical_environment for each + variable we bind, instead of all at once like `let'. + +2004-08-09 Miles Bader + + Changes from merging the funvec patch: + + * eval.c (Feval, Ffuncall): Don't special-case vectors. + (funcall_lambda): Use FUNVEC_SIZE. + (Fcurry): Remove function. + + Merge funvec patch. + +2004-04-10 Miles Bader + + * eval.c (Fspecialp): New function. + (syms_of_eval): Initialize it. + +2004-04-03 Miles Bader + + * eval.c (Feval): If a variable isn't bound lexically, fall back + to looking it up dynamically even if it isn't declared special. + +2002-08-26 Miles Bader + + * bytecode.c (Fbyte_code): Fsub1 can GC, so protect it. + +2002-06-12 Miles Bader + + Lexical binding changes to the byte-code interpreter: + + * bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, Bvec_ref, Bvec_set) + (BdiscardN): New constants. + (exec_byte_code): Renamed from `Fbyte_code'. + Implement above new bytecodes. + Add ARGS-TEMPLATE, NARGS and ARGS parameters, and optionally use + them push initial args on the stack. + (Fbyte_code): New function, just call `exec_byte_code'. + Add additional optional arguments for `exec_byte_code'. + (Qand_optional, Qand_rest): New extern declarations. + * eval.c (Fcurry, Ffunctionp): New functions. + (syms_of_eval): Initialize them. + (funcall_lambda): Call `exec_byte_code' instead of Fbyte_code. + If a compiled-function object has a `push-args' slot, call the + byte-code interpreter without binding any arguments. + (Ffuncall): Add support for curried functions. + * lisp.h (Fbyte_code): Declare max-args as MANY. + (exec_byte_code): New declaration. + + Lexical binding changes to the lisp interpreter: + + * lisp.h (struct Lisp_Symbol): Add `declared_special' field. + (apply_lambda): Add new 3rd arg to decl. + * alloc.c (Fmake_symbol): Initialize `declared_special' field. + * eval.c (Vinterpreter_lexical_environment): New variable. + (syms_of_eval): Initialize it. + (Fsetq): Modify SYM's lexical binding if appropriate. + (Ffunction): Return a closure if within a lexical environment. + (Flet, FletX): Lexically bind non-defvar'd variables if inside a + lexical environment. + (Feval): Return lexical binding of variables, if they have one. + Pass current lexical environment to embedded lambdas. Handle closures. + (Ffuncall): Pass nil lexical environment to lambdas. Handle closures. + (funcall_lambda): Add new LEXENV argument, and lexically bind + arguments if it's non-nil. Bind `interpreter-lexenv' if it changed. + (apply_lambda): Add new LEXENV argument and pass it to funcall_lambda. + (Fdefvaralias, Fdefvar, Fdefconst): Mark the variable as special. + (Qinternal_interpreter_environment, Qclosure): New constants. + (syms_of_eval): Initialize them. + (Fdefun, Fdefmacro): Use a closure if lexical binding is active. + * lread.c (defvar_bool, defvar_lisp_nopro, defvar_per_buffer) + (defvar_kboard, defvar_int): Mark the variable as special. + (Vlexical_binding, Qlexical_binding): New variables. + (syms_of_lread): Initialize them. + (Fload): Bind `lexically-bound' to nil unless specified otherwise + in the file header. + (lisp_file_lexically_bound_p): New function. + (Qinternal_interpreter_environment): New variable. + * doc.c (Qclosure): New extern declaration. + (Fdocumentation, store_function_docstring): Handle interpreted + closures. + +;; arch-tag: 7cf884aa-6b48-40cb-bfca-265a1e99b3c5 diff --git a/src/alloc.c b/src/alloc.c index e0f07cc5f5..a23c688043 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3042,6 +3042,39 @@ 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 (kind, num_nil_slots, num_params, params) + Lisp_Object kind; + int num_nil_slots, 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. @@ -3063,6 +3096,29 @@ 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) */) + (nargs, args) + register 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, @@ -3078,6 +3134,10 @@ 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); @@ -3099,8 +3159,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_COMPILED); - XSETCOMPILED (val, p); + XSETPVECTYPE (p, PVEC_FUNVEC); + XSETFUNVEC (val, p); return val; } @@ -3199,6 +3259,7 @@ Its value and function definition are void, and its property list is nil. */) p->gcmarkbit = 0; p->interned = SYMBOL_UNINTERNED; p->constant = 0; + p->declared_special = 0; consing_since_gc += sizeof (struct Lisp_Symbol); symbols_consed++; return val; @@ -4907,7 +4968,7 @@ Does not copy symbols. Copies strings without text properties. */) obj = make_pure_string (SDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj)) + else if (FUNVECP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; register int i; @@ -4919,10 +4980,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 (COMPILEDP (obj)) + if (FUNVECP (obj)) { - XSETPVECTYPE (vec, PVEC_COMPILED); - XSETCOMPILED (obj, vec); + XSETPVECTYPE (vec, PVEC_FUNVEC); + XSETFUNVEC (obj, vec); } else XSETVECTOR (obj, vec); @@ -5512,7 +5573,7 @@ mark_object (arg) } else if (SUBRP (obj)) break; - else if (COMPILEDP (obj)) + else if (FUNVECP (obj) && FUNVEC_COMPILED_P (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. */ @@ -6423,6 +6484,7 @@ 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/buffer.c b/src/buffer.c index 589266f40e..e907c295e8 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -5418,6 +5418,7 @@ defvar_per_buffer (bo_fwd, namestring, address, type, doc) bo_fwd->type = Lisp_Fwd_Buffer_Obj; bo_fwd->offset = offset; bo_fwd->slottype = type; + sym->declared_special = 1; sym->redirect = SYMBOL_FORWARDED; { /* I tried to do the job without a cast, but it seems impossible. diff --git a/src/bytecode.c b/src/bytecode.c index c53c5acdbb..fec855c0b8 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -87,9 +87,11 @@ int byte_metering_on; Lisp_Object Qbytecode; +extern Lisp_Object Qand_optional, Qand_rest; /* Byte codes: */ +#define Bstack_ref 0 #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -229,6 +231,13 @@ Lisp_Object Qbytecode; #define BconcatN 0260 #define BinsertN 0261 +/* Bstack_ref is code 0. */ +#define Bstack_set 0262 +#define Bstack_set2 0263 +#define Bvec_ref 0264 +#define Bvec_set 0265 +#define BdiscardN 0266 + #define Bconstant 0300 #define CONSTANTLIM 0100 @@ -397,14 +406,41 @@ unmark_byte_stack () } while (0) -DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, +DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; the second, VECTOR, a vector of constants; the third, MAXDEPTH, the maximum stack depth used in this function. -If the third argument is incorrect, Emacs may crash. */) - (bytestr, vector, maxdepth) - Lisp_Object bytestr, vector, maxdepth; +If the third argument is incorrect, Emacs may crash. + +If ARGS-TEMPLATE is specified, it is an argument list specification, +according to which any remaining arguments are pushed on the stack +before executing BYTESTR. + +usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */) + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil; + int pnargs = nargs >= 4 ? nargs - 4 : 0; + Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0; + return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs); +} + +/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and + MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, + emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp + argument list (including &rest, &optional, etc.), and ARGS, of size + NARGS, should be a vector of the actual arguments. The arguments in + ARGS are pushed on the stack according to ARGS_TEMPLATE before + executing BYTESTR. */ + +Lisp_Object +exec_byte_code (bytestr, vector, maxdepth, args_template, nargs, args) + Lisp_Object bytestr, vector, maxdepth, args_template; + int nargs; + Lisp_Object *args; { int count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER @@ -462,6 +498,37 @@ If the third argument is incorrect, Emacs may crash. */) stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif + if (! NILP (args_template)) + /* We should push some arguments on the stack. */ + { + 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 (Flist (nargs, args)); + pushed = nargs; + at = Qnil; + break; + } + else if (pushed < nargs) + { + PUSH (*args++); + pushed++; + } + else if (optional) + PUSH (Qnil); + else + break; + + if (pushed != nargs || !NILP (at)) + Fsignal (Qwrong_number_of_arguments, + Fcons (args_template, Fcons (make_number (nargs), Qnil))); + } + while (1) { #ifdef BYTE_CODE_SAFE @@ -1641,8 +1708,57 @@ If the third argument is incorrect, Emacs may crash. */) break; #endif - case 0: - abort (); + /* Handy byte-codes for lexical binding. */ + case Bstack_ref: + case Bstack_ref+1: + case Bstack_ref+2: + case Bstack_ref+3: + case Bstack_ref+4: + case Bstack_ref+5: + PUSH (stack.bottom[op - Bstack_ref]); + break; + case Bstack_ref+6: + PUSH (stack.bottom[FETCH]); + break; + case Bstack_ref+7: + PUSH (stack.bottom[FETCH2]); + break; + case Bstack_set: + stack.bottom[FETCH] = POP; + break; + case Bstack_set2: + stack.bottom[FETCH2] = POP; + break; + case Bvec_ref: + case Bvec_set: + /* These byte-codes used mostly for variable references to + lexically bound variables that are in an environment vector + instead of on the byte-interpreter stack (generally those + variables which might be shared with a closure). */ + { + int index = FETCH; + Lisp_Object vec = POP; + + if (! VECTORP (vec)) + wrong_type_argument (Qvectorp, vec); + else if (index < 0 || index >= XVECTOR (vec)->size) + args_out_of_range (vec, index); + + if (op == Bvec_ref) + PUSH (XVECTOR (vec)->contents[index]); + else + XVECTOR (vec)->contents[index] = POP; + } + break; + case BdiscardN: + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + top[-op] = TOP; + } + DISCARD (op); + break; case 255: default: diff --git a/src/data.c b/src/data.c index 93cc57e9f2..6a21ad4472 100644 --- a/src/data.c +++ b/src/data.c @@ -84,7 +84,7 @@ Lisp_Object Qinteger; static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; Lisp_Object Qprocess; -static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; +static Lisp_Object Qcompiled_function, Qfunction_vector, 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; @@ -219,8 +219,11 @@ for example, (type-of 1) returns `integer'. */) return Qwindow; if (SUBRP (object)) return Qsubr; - if (COMPILEDP (object)) - return Qcompiled_function; + if (FUNVECP (object)) + if (FUNVEC_COMPILED_P (object)) + return Qcompiled_function; + else + return Qfunction_vector; if (BUFFERP (object)) return Qbuffer; if (CHAR_TABLE_P (object)) @@ -437,6 +440,14 @@ 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. */) + (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. */) (object) @@ -2208,15 +2219,15 @@ or a byte-code object. IDX starts at 0. */) { int size = 0; if (VECTORP (array)) - size = XVECTOR (array)->size; - else if (COMPILEDP (array)) - size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; + size = ASIZE (array); + else if (FUNVECP (array)) + size = FUNVEC_SIZE (array); else wrong_type_argument (Qarrayp, array); if (idxval < 0 || idxval >= size) args_out_of_range (array, idx); - return XVECTOR (array)->contents[idxval]; + return AREF (array, idxval); } } @@ -3326,6 +3337,7 @@ syms_of_data () 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"); @@ -3351,6 +3363,7 @@ syms_of_data () staticpro (&Qwindow); /* staticpro (&Qsubr); */ staticpro (&Qcompiled_function); + staticpro (&Qfunction_vector); staticpro (&Qbuffer); staticpro (&Qframe); staticpro (&Qvector); @@ -3387,6 +3400,7 @@ syms_of_data () 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 536d22c57a..9133c2e6b8 100644 --- a/src/doc.c +++ b/src/doc.c @@ -56,7 +56,7 @@ Lisp_Object Qfunction_documentation; /* A list of files used to build this Emacs binary. */ static Lisp_Object Vbuild_files; -extern Lisp_Object Voverriding_local_map; +extern Lisp_Object Voverriding_local_map, Qclosure; extern Lisp_Object Qremap; @@ -385,6 +385,11 @@ 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."); @@ -412,6 +417,8 @@ string is passed through `substitute-command-keys'. */) else return Qnil; } + else if (EQ (funcar, Qclosure)) + return Fdocumentation (Fcdr (XCDR (fun)), raw); else if (EQ (funcar, Qmacro)) return Fdocumentation (Fcdr (fun), raw); else @@ -542,6 +549,8 @@ store_function_docstring (fun, offset) } else if (EQ (tem, Qmacro)) store_function_docstring (XCDR (fun), offset); + else if (EQ (tem, Qclosure)) + store_function_docstring (Fcdr (XCDR (fun)), offset); } /* Bytecode objects sometimes have slots for it. */ diff --git a/src/eval.c b/src/eval.c index 199c470573..875b4498a6 100644 --- a/src/eval.c +++ b/src/eval.c @@ -62,6 +62,9 @@ Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; +Lisp_Object Qcurry, Qunevalled; +Lisp_Object Qinternal_interpreter_environment, Qclosure; + Lisp_Object Qdebug; extern Lisp_Object Qinteractive_form; @@ -78,6 +81,13 @@ Lisp_Object Vrun_hooks; Lisp_Object Vautoload_queue; +/* When lexical binding is being used, this is non-nil, and contains an + alist of lexically-bound variable, or t, indicating an empty + environment. The lisp name of this variable is + `internal-interpreter-lexical-environment'. */ + +Lisp_Object Vinternal_interpreter_environment; + /* Current number of specbindings allocated in specpdl. */ int specpdl_size; @@ -167,10 +177,11 @@ int handling_signal; Lisp_Object Vmacro_declaration_function; extern Lisp_Object Qrisky_local_variable; - extern Lisp_Object Qfunction; -static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object*)); +static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object *, + Lisp_Object)); + static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN; #if __GNUC__ @@ -504,7 +515,7 @@ usage: (setq [SYM VAL]...) */) Lisp_Object args; { register Lisp_Object args_left; - register Lisp_Object val, sym; + register Lisp_Object val, sym, lex_binding; struct gcpro gcpro1; if (NILP (args)) @@ -517,7 +528,15 @@ usage: (setq [SYM VAL]...) */) { val = Feval (Fcar (Fcdr (args_left))); sym = Fcar (args_left); - Fset (sym, val); + + if (!NILP (Vinternal_interpreter_environment) + && SYMBOLP (sym) + && !XSYMBOL (sym)->declared_special + && !NILP (lex_binding = Fassq (sym, Vinternal_interpreter_environment))) + XSETCDR (lex_binding, val); /* SYM is lexically bound. */ + else + Fset (sym, val); /* SYM is dynamically bound. */ + args_left = Fcdr (Fcdr (args_left)); } while (!NILP(args_left)); @@ -545,9 +564,20 @@ usage: (function ARG) */) (args) Lisp_Object args; { + Lisp_Object quoted = XCAR (args); + if (!NILP (Fcdr (args))) xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); - return Fcar (args); + + if (!NILP (Vinternal_interpreter_environment) + && CONSP (quoted) + && EQ (XCAR (quoted), Qlambda)) + /* This is a lambda expression within a lexical environment; + return an interpreted closure instead of a simple lambda. */ + return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, quoted)); + else + /* Simply quote the argument. */ + return quoted; } @@ -570,7 +600,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii) use `called-interactively-p'. */) () { - return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; + return interactive_p (1) ? Qt : Qnil; } @@ -666,6 +696,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */) fn_name = Fcar (args); CHECK_SYMBOL (fn_name); defn = Fcons (Qlambda, Fcdr (args)); + if (! NILP (Vinternal_interpreter_environment)) + defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn)); if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); if (CONSP (XSYMBOL (fn_name)->function) @@ -738,7 +770,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */) tail = Fcons (lambda_list, tail); else tail = Fcons (lambda_list, Fcons (doc, tail)); - defn = Fcons (Qmacro, Fcons (Qlambda, tail)); + + defn = Fcons (Qlambda, tail); + if (! NILP (Vinternal_interpreter_environment)) + defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn)); + defn = Fcons (Qmacro, defn); if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); @@ -799,6 +835,7 @@ The return value is BASE-VARIABLE. */) error ("Don't know how to make a let-bound variable an alias"); } + sym->declared_special = 1; sym->redirect = SYMBOL_VARALIAS; SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); sym->constant = SYMBOL_CONSTANT_P (base_variable); @@ -889,6 +926,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) It could get in the way of other definitions, and unloading this package could try to make the variable unbound. */ ; + + if (SYMBOLP (sym)) + XSYMBOL (sym)->declared_special = 1; return sym; } @@ -918,6 +958,7 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */) if (!NILP (Vpurify_flag)) tem = Fpurecopy (tem); Fset_default (sym, tem); + XSYMBOL (sym)->declared_special = 1; tem = Fcar (Fcdr (Fcdr (args))); if (!NILP (tem)) { @@ -1006,30 +1047,50 @@ usage: (let* VARLIST BODY...) */) (args) Lisp_Object args; { - Lisp_Object varlist, val, elt; + Lisp_Object varlist, var, val, elt, lexenv; int count = SPECPDL_INDEX (); struct gcpro gcpro1, gcpro2, gcpro3; GCPRO3 (args, elt, varlist); + lexenv = Vinternal_interpreter_environment; + varlist = Fcar (args); - while (!NILP (varlist)) + while (CONSP (varlist)) { QUIT; - elt = Fcar (varlist); + + elt = XCAR (varlist); if (SYMBOLP (elt)) - specbind (elt, Qnil); + { + var = elt; + val = Qnil; + } else if (! NILP (Fcdr (Fcdr (elt)))) signal_error ("`let' bindings can have only one value-form", elt); else { + var = Fcar (elt); val = Feval (Fcar (Fcdr (elt))); - specbind (Fcar (elt), val); } - varlist = Fcdr (varlist); + + if (!NILP (lexenv) && SYMBOLP (var) && !XSYMBOL (var)->declared_special) + /* Lexically bind VAR by adding it to the interpreter's binding + alist. */ + { + lexenv = Fcons (Fcons (var, val), lexenv); + specbind (Qinternal_interpreter_environment, lexenv); + } + else + specbind (var, val); + + varlist = XCDR (varlist); } + UNGCPRO; + val = Fprogn (Fcdr (args)); + return unbind_to (count, val); } @@ -1043,7 +1104,7 @@ usage: (let VARLIST BODY...) */) (args) Lisp_Object args; { - Lisp_Object *temps, tem; + Lisp_Object *temps, tem, lexenv; register Lisp_Object elt, varlist; int count = SPECPDL_INDEX (); register int argnum; @@ -1074,18 +1135,31 @@ usage: (let VARLIST BODY...) */) } UNGCPRO; + lexenv = Vinternal_interpreter_environment; + varlist = Fcar (args); for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { + Lisp_Object var; + elt = XCAR (varlist); + var = SYMBOLP (elt) ? elt : Fcar (elt); tem = temps[argnum++]; - if (SYMBOLP (elt)) - specbind (elt, tem); + + if (!NILP (lexenv) && SYMBOLP (var) && !XSYMBOL (var)->declared_special) + /* Lexically bind VAR by adding it to the lexenv alist. */ + lexenv = Fcons (Fcons (var, tem), lexenv); else - specbind (Fcar (elt), tem); + /* Dynamically bind VAR. */ + specbind (var, tem); } + if (!EQ (lexenv, Vinternal_interpreter_environment)) + /* Instantiate a new lexical environment. */ + specbind (Qinternal_interpreter_environment, lexenv); + elt = Fprogn (Fcdr (args)); + return unbind_to (count, elt); } @@ -2292,7 +2366,28 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, abort (); if (SYMBOLP (form)) - return Fsymbol_value (form); + { + /* If there's an active lexical environment, and the variable + isn't declared special, look up its binding in the lexical + environment. */ + if (!NILP (Vinternal_interpreter_environment) + && !XSYMBOL (form)->declared_special) + { + Lisp_Object lex_binding + = Fassq (form, Vinternal_interpreter_environment); + + /* If we found a lexical binding for FORM, return the value. + Otherwise, we just drop through and look for a dynamic + binding -- the variable isn't declared special, but there's + not much else we can do, and Fsymbol_value will take care + of signaling an error if there is no binding at all. */ + if (CONSP (lex_binding)) + return XCDR (lex_binding); + } + + return Fsymbol_value (form); + } + if (!CONSP (form)) return form; @@ -2452,8 +2547,8 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, abort (); } } - if (COMPILEDP (fun)) - val = apply_lambda (fun, original_args, 1); + if (FUNVECP (fun)) + val = apply_lambda (fun, original_args, 1, Qnil); else { if (EQ (fun, Qunbound)) @@ -2471,7 +2566,18 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, if (EQ (funcar, Qmacro)) val = Feval (apply1 (Fcdr (fun), original_args)); else if (EQ (funcar, Qlambda)) - val = apply_lambda (fun, original_args, 1); + val = apply_lambda (fun, original_args, 1, + /* Only pass down the current lexical environment + if FUN is lexically embedded in FORM. */ + (CONSP (original_fun) + ? Vinternal_interpreter_environment + : Qnil)); + else if (EQ (funcar, Qclosure) + && CONSP (XCDR (fun)) + && CONSP (XCDR (XCDR (fun))) + && EQ (XCAR (XCDR (XCDR (fun))), Qlambda)) + val = apply_lambda (XCDR (XCDR (fun)), original_args, 1, + XCAR (XCDR (fun))); else xsignal1 (Qinvalid_function, original_fun); } @@ -2981,6 +3087,40 @@ call7 (fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7) /* The caller should GCPRO all the elements of ARGS. */ +DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, + doc: /* Return non-nil if OBJECT is a type of object that can be called as a function. */) + (object) + Lisp_Object object; +{ + if (SYMBOLP (object) && !NILP (Ffboundp (object))) + { + object = Findirect_function (object, Qnil); + + if (CONSP (object) && EQ (XCAR (object), Qautoload)) + { + /* Autoloaded symbols are functions, except if they load + macros or keymaps. */ + int i; + for (i = 0; i < 4 && CONSP (object); i++) + object = XCDR (object); + + return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt; + } + } + + if (SUBRP (object)) + return (XSUBR (object)->max_args != Qunevalled) ? Qt : Qnil; + else if (FUNVECP (object)) + return Qt; + else if (CONSP (object)) + { + Lisp_Object car = XCAR (object); + return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil; + } + else + return Qnil; +} + DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, doc: /* Call first argument as a function, passing remaining arguments to it. Return the value that function returns. @@ -3115,8 +3255,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) abort (); } } - if (COMPILEDP (fun)) - val = funcall_lambda (fun, numargs, args + 1); + + if (FUNVECP (fun)) + val = funcall_lambda (fun, numargs, args + 1, Qnil); else { if (EQ (fun, Qunbound)) @@ -3127,7 +3268,13 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original_fun); if (EQ (funcar, Qlambda)) - val = funcall_lambda (fun, numargs, args + 1); + val = funcall_lambda (fun, numargs, args + 1, Qnil); + else if (EQ (funcar, Qclosure) + && CONSP (XCDR (fun)) + && CONSP (XCDR (XCDR (fun))) + && EQ (XCAR (XCDR (XCDR (fun))), Qlambda)) + val = funcall_lambda (XCDR (XCDR (fun)), numargs, args + 1, + XCAR (XCDR (fun))); else if (EQ (funcar, Qautoload)) { do_autoload (fun, original_fun); @@ -3147,9 +3294,10 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } Lisp_Object -apply_lambda (fun, args, eval_flag) +apply_lambda (fun, args, eval_flag, lexenv) Lisp_Object fun, args; int eval_flag; + Lisp_Object lexenv; { Lisp_Object args_left; Lisp_Object numargs; @@ -3181,7 +3329,7 @@ apply_lambda (fun, args, eval_flag) backtrace_list->nargs = i; } backtrace_list->evalargs = 0; - tem = funcall_lambda (fun, XINT (numargs), arg_vector); + tem = funcall_lambda (fun, XINT (numargs), arg_vector, lexenv); /* Do the debug-on-exit now, while arg_vector still exists. */ if (backtrace_list->debug_on_exit) @@ -3191,20 +3339,100 @@ apply_lambda (fun, args, eval_flag) return tem; } + +/* Call a non-bytecode funvec object FUN, on the argments in ARGS (of + length NARGS). */ + +static Lisp_Object +funcall_funvec (fun, nargs, args) + 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. */ + bcopy (curried_args, funcall_args + curried_args_offs, + num_curried_args * sizeof (Lisp_Object)); + bcopy (args, funcall_args + user_args_offs, + 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. */ static Lisp_Object -funcall_lambda (fun, nargs, arg_vector) +funcall_lambda (fun, nargs, arg_vector, lexenv) Lisp_Object fun; int nargs; register Lisp_Object *arg_vector; + Lisp_Object lexenv; { Lisp_Object val, syms_left, next; 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)) { syms_left = XCDR (fun); @@ -3236,12 +3464,27 @@ funcall_lambda (fun, nargs, arg_vector) specbind (next, Flist (nargs - i, &arg_vector[i])); i = nargs; } - else if (i < nargs) - specbind (next, arg_vector[i++]); - else if (!optional) - xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); else - specbind (next, Qnil); + { + Lisp_Object val; + + /* Get the argument's actual value. */ + if (i < nargs) + val = arg_vector[i++]; + else if (!optional) + xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + else + val = Qnil; + + /* Bind the argument. */ + if (!NILP (lexenv) + && SYMBOLP (next) && !XSYMBOL (next)->declared_special) + /* Lexically bind NEXT by adding it to the lexenv alist. */ + lexenv = Fcons (Fcons (next, val), lexenv); + else + /* Dynamically bind NEXT. */ + specbind (next, val); + } } if (!NILP (syms_left)) @@ -3249,6 +3492,10 @@ funcall_lambda (fun, nargs, arg_vector) else if (i < nargs) xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + if (!EQ (lexenv, Vinternal_interpreter_environment)) + /* Instantiate a new lexical environment. */ + specbind (Qinternal_interpreter_environment, lexenv); + if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else @@ -3257,9 +3504,10 @@ funcall_lambda (fun, nargs, arg_vector) and constants vector yet, fetch them from the file. */ if (CONSP (AREF (fun, COMPILED_BYTECODE))) Ffetch_bytecode (fun); - val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH)); + val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + Qnil, 0, 0); } return unbind_to (count, val); @@ -3502,7 +3750,42 @@ unbind_to (count, value) UNGCPRO; return value; } + + +DEFUN ("specialp", Fspecialp, Sspecialp, 1, 1, 0, + doc: /* Return non-nil if SYMBOL's global binding has been declared special. +A special variable is one that will be bound dynamically, even in a +context where binding is lexical by default. */) + (symbol) + Lisp_Object symbol; +{ + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->declared_special ? Qt : Qnil; +} + + + +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) */) + (nargs, args) + register 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. */) @@ -3713,6 +3996,15 @@ before making `inhibit-quit' nil. */); Qand_optional = intern_c_string ("&optional"); staticpro (&Qand_optional); + Qclosure = intern_c_string ("closure"); + staticpro (&Qclosure); + + Qcurry = intern_c_string ("curry"); + staticpro (&Qcurry); + + Qunevalled = intern_c_string ("unevalled"); + staticpro (&Qunevalled); + Qdebug = intern_c_string ("debug"); staticpro (&Qdebug); @@ -3788,6 +4080,17 @@ DECL is a list `(declare ...)' containing the declarations. The value the function returns is not used. */); Vmacro_declaration_function = Qnil; + Qinternal_interpreter_environment + = intern_c_string ("internal-interpreter-environment"); + staticpro (&Qinternal_interpreter_environment); + DEFVAR_LISP ("internal-interpreter-environment", + &Vinternal_interpreter_environment, + doc: /* If non-nil, the current lexical environment of the lisp interpreter. +When lexical binding is not being used, this variable is nil. +A value of `(t)' indicates an empty environment, otherwise it is an +alist of active lexical bindings. */); + Vinternal_interpreter_environment = Qnil; + Vrun_hooks = intern_c_string ("run-hooks"); staticpro (&Vrun_hooks); @@ -3833,9 +4136,13 @@ The value the function returns is not used. */); 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 (&Sspecialp); + defsubr (&Sfunctionp); } /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb diff --git a/src/fns.c b/src/fns.c index 3f984905d1..9569c21426 100644 --- a/src/fns.c +++ b/src/fns.c @@ -149,8 +149,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 (COMPILEDP (sequence)) - XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); + else if (FUNVECP (sequence)) + XSETFASTINT (val, FUNVEC_SIZE (sequence)); else if (CONSP (sequence)) { i = 0; @@ -535,7 +535,7 @@ concat (nargs, args, target_type, last_special) { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) - || COMPILEDP (this) || BOOL_VECTOR_P (this))) + || FUNVECP (this) || BOOL_VECTOR_P (this))) wrong_type_argument (Qsequencep, this); } @@ -559,7 +559,7 @@ concat (nargs, args, target_type, last_special) Lisp_Object ch; int this_len_byte; - if (VECTORP (this)) + if (VECTORP (this) || FUNVECP (this)) for (i = 0; i < len; i++) { ch = AREF (this, i); @@ -1383,7 +1383,9 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, return Fcar (Fnthcdr (n, sequence)); /* Faref signals a "not array" error, so check here. */ - CHECK_ARRAY (sequence, Qsequencep); + if (! FUNVECP (sequence)) + CHECK_ARRAY (sequence, Qsequencep); + return Faref (sequence, n); } @@ -2199,13 +2201,14 @@ internal_equal (o1, o2, depth, props) if (WINDOW_CONFIGURATIONP (o1)) return compare_window_configurations (o1, o2, 0); - /* 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. */ + /* 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. */ if (size & PSEUDOVECTOR_FLAG) { - if (!(size & (PVEC_COMPILED - | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT))) + if (!(size & (PVEC_FUNVEC + | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE + | PVEC_FONT))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -2416,7 +2419,7 @@ mapcar1 (leni, vals, fn, seq) 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */ - if (VECTORP (seq)) + if (VECTORP (seq) || FUNVECP (seq)) { for (i = 0; i < leni; i++) { diff --git a/src/image.c b/src/image.c index b9620e1094..67c228cbc7 100644 --- a/src/image.c +++ b/src/image.c @@ -885,7 +885,7 @@ parse_image_spec (spec, keywords, nkeywords, type) case IMAGE_FUNCTION_VALUE: value = indirect_function (value); if (SUBRP (value) - || COMPILEDP (value) + || FUNVECP (value) || (CONSP (value) && EQ (XCAR (value), Qlambda))) break; return 0; diff --git a/src/keyboard.c b/src/keyboard.c index 63372d600e..18d75f9b01 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10390,7 +10390,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) || COMPILEDP (final)) + if (CONSP (final) || SUBRP (final) || FUNVECP (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 1941a2471a..c7e8ea0fb8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -344,7 +344,7 @@ enum pvec_type PVEC_NORMAL_VECTOR = 0, PVEC_PROCESS = 0x200, PVEC_FRAME = 0x400, - PVEC_COMPILED = 0x800, + PVEC_FUNVEC = 0x800, PVEC_WINDOW = 0x1000, PVEC_WINDOW_CONFIGURATION = 0x2000, PVEC_SUBR = 0x4000, @@ -623,7 +623,7 @@ extern size_t pure_size; #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 XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) +#define XSETFUNVEC(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FUNVEC)) #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)) @@ -639,6 +639,9 @@ extern size_t pure_size; 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) @@ -1020,6 +1023,10 @@ struct Lisp_Symbol /* Interned state of the symbol. This is an enumerator from enum symbol_interned. */ unsigned interned : 2; + + /* Non-zero means that this variable has been explicitly declared + special (with `defvar' etc), and shouldn't be lexically bound. */ + unsigned declared_special : 1; /* The symbol's name, as a Lisp string. @@ -1475,7 +1482,7 @@ struct Lisp_Float typedef unsigned char UCHAR; #endif -/* Meanings of slots in a Lisp_Compiled: */ +/* Meanings of slots in a byte-compiled function vector: */ #define COMPILED_ARGLIST 0 #define COMPILED_BYTECODE 1 @@ -1483,6 +1490,25 @@ typedef unsigned char UCHAR; #define COMPILED_STACK_DEPTH 3 #define COMPILED_DOC_STRING 4 #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 @@ -1604,7 +1630,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 COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED) +#define FUNVECP(x) PSEUDOVECTORP (x, PVEC_FUNVEC) #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) @@ -1797,7 +1823,7 @@ typedef struct { #define FUNCTIONP(OBJ) \ ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ - || COMPILEDP (OBJ) \ + || FUNVECP (OBJ) \ || SUBRP (OBJ)) /* defsubr (Sname); @@ -2697,6 +2723,7 @@ EXFUN (Fmake_list, 2); extern Lisp_Object allocate_misc P_ ((void)); EXFUN (Fmake_vector, 2); EXFUN (Fvector, MANY); +EXFUN (Ffunvec, MANY); EXFUN (Fmake_symbol, 1); EXFUN (Fmake_marker, 0); EXFUN (Fmake_string, 2); @@ -2715,6 +2742,7 @@ extern Lisp_Object make_pure_c_string (const char *data); extern Lisp_Object pure_cons P_ ((Lisp_Object, Lisp_Object)); extern Lisp_Object make_pure_vector P_ ((EMACS_INT)); EXFUN (Fgarbage_collect, 0); +extern Lisp_Object make_funvec P_ ((Lisp_Object, int, int, Lisp_Object *)); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_bool_vector, 2); extern Lisp_Object Qchar_table_extra_slots; @@ -2894,7 +2922,7 @@ extern Lisp_Object call5 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object extern Lisp_Object call6 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)); extern Lisp_Object call7 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)); EXFUN (Fdo_auto_save, 2); -extern Lisp_Object apply_lambda P_ ((Lisp_Object, Lisp_Object, int)); +extern Lisp_Object apply_lambda P_ ((Lisp_Object, Lisp_Object, int, Lisp_Object)); extern Lisp_Object internal_catch P_ ((Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object)); extern Lisp_Object internal_lisp_condition_case P_ ((Lisp_Object, Lisp_Object, Lisp_Object)); extern Lisp_Object internal_condition_case P_ ((Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object))); @@ -3312,11 +3340,13 @@ extern int read_bytecode_char P_ ((int)); /* Defined in bytecode.c */ extern Lisp_Object Qbytecode; -EXFUN (Fbyte_code, 3); +EXFUN (Fbyte_code, MANY); extern void syms_of_bytecode P_ ((void)); extern struct byte_stack *byte_stack_list; extern void mark_byte_stack P_ ((void)); extern void unmark_byte_stack P_ ((void)); +extern Lisp_Object exec_byte_code P_ ((Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, int, Lisp_Object *)); /* Defined in macros.c */ extern Lisp_Object Qexecute_kbd_macro; diff --git a/src/lread.c b/src/lread.c index 3a77a62b27..53f26faea3 100644 --- a/src/lread.c +++ b/src/lread.c @@ -83,6 +83,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name; Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; Lisp_Object Qinhibit_file_name_operation; Lisp_Object Qeval_buffer_list, Veval_buffer_list; +Lisp_Object Qlexical_binding; Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ /* Used instead of Qget_file_char while loading *.elc files compiled @@ -93,6 +94,7 @@ static Lisp_Object Qload_force_doc_strings; extern Lisp_Object Qevent_symbol_element_mask; extern Lisp_Object Qfile_exists_p; +extern Lisp_Object Qinternal_interpreter_environment; /* non-zero if inside `load' */ int load_in_progress; @@ -157,6 +159,9 @@ Lisp_Object Vread_with_symbol_positions; /* List of (SYMBOL . POSITION) accumulated so far. */ Lisp_Object Vread_symbol_positions_list; +/* If non-nil `readevalloop' evaluates code in a lexical environment. */ +Lisp_Object Vlexical_binding; + /* List of descriptors now open for Fload. */ static Lisp_Object load_descriptor_list; @@ -864,6 +869,118 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, + +/* Return true if the lisp code read using READCHARFUN defines a non-nil + `lexical-binding' file variable. After returning, the stream is + positioned following the first line, if it is a comment, otherwise + nothing is read. */ + +static int +lisp_file_lexically_bound_p (readcharfun) + Lisp_Object readcharfun; +{ + int ch = READCHAR; + if (ch != ';') + /* The first line isn't a comment, just give up. */ + { + UNREAD (ch); + return 0; + } + else + /* Look for an appropriate file-variable in the first line. */ + { + int rv = 0; + enum { + NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX, + } beg_end_state = NOMINAL; + int in_file_vars = 0; + +#define UPDATE_BEG_END_STATE(ch) \ + if (beg_end_state == NOMINAL) \ + beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \ + else if (beg_end_state == AFTER_FIRST_DASH) \ + beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \ + else if (beg_end_state == AFTER_ASTERIX) \ + { \ + if (ch == '-') \ + in_file_vars = !in_file_vars; \ + beg_end_state = NOMINAL; \ + } + + /* Skip until we get to the file vars, if any. */ + do + { + ch = READCHAR; + UPDATE_BEG_END_STATE (ch); + } + while (!in_file_vars && ch != '\n' && ch != EOF); + + while (in_file_vars) + { + char var[100], *var_end, val[100], *val_end; + + ch = READCHAR; + + /* Read a variable name. */ + while (ch == ' ' || ch == '\t') + ch = READCHAR; + + var_end = var; + while (ch != ':' && ch != '\n' && ch != EOF) + { + if (var_end < var + sizeof var - 1) + *var_end++ = ch; + UPDATE_BEG_END_STATE (ch); + ch = READCHAR; + } + + while (var_end > var + && (var_end[-1] == ' ' || var_end[-1] == '\t')) + var_end--; + *var_end = '\0'; + + if (ch == ':') + { + /* Read a variable value. */ + ch = READCHAR; + + while (ch == ' ' || ch == '\t') + ch = READCHAR; + + val_end = val; + while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars) + { + if (val_end < val + sizeof val - 1) + *val_end++ = ch; + UPDATE_BEG_END_STATE (ch); + ch = READCHAR; + } + if (! in_file_vars) + /* The value was terminated by an end-marker, which + remove. */ + val_end -= 3; + while (val_end > val + && (val_end[-1] == ' ' || val_end[-1] == '\t')) + val_end--; + *val_end = '\0'; + + if (strcmp (var, "lexical-binding") == 0) + /* This is it... */ + { + rv = (strcmp (val, "nil") != 0); + break; + } + } + } + + while (ch != '\n' && ch != EOF) + ch = READCHAR; + + return rv; + } +} + + /* Value is a version number of byte compiled code if the file associated with file descriptor FD is a compiled Lisp file that's safe to load. Only files compiled with Emacs are safe to load. @@ -1129,6 +1246,12 @@ Return t if the file exists and loads successfully. */) Vloads_in_progress = Fcons (found, Vloads_in_progress); } + /* All loads are by default dynamic, unless the file itself specifies + otherwise using a file-variable in the first line. This is bound here + so that it takes effect whether or not we use + Vload_source_file_function. */ + specbind (Qlexical_binding, Qnil); + /* Get the name for load-history. */ hist_file_name = (! NILP (Vpurify_flag) ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), @@ -1253,7 +1376,13 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); load_descriptor_list = Fcons (make_number (fileno (stream)), load_descriptor_list); + specbind (Qload_in_progress, Qt); + + instream = stream; + if (lisp_file_lexically_bound_p (Qget_file_char)) + Fset (Qlexical_binding, Qt); + if (! version || version >= 22) readevalloop (Qget_file_char, stream, hist_file_name, Feval, 0, Qnil, Qnil, Qnil, Qnil); @@ -1652,6 +1781,7 @@ readevalloop (readcharfun, stream, sourcename, evalfun, struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; struct buffer *b = 0; int continue_reading_p; + Lisp_Object lex_bound; /* Nonzero if reading an entire buffer. */ int whole_buffer = 0; /* 1 on the first time around. */ @@ -1677,6 +1807,15 @@ readevalloop (readcharfun, stream, sourcename, evalfun, record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); load_convert_to_unibyte = !NILP (unibyte); + /* If lexical binding is active (either because it was specified in + the file's header, or via a buffer-local variable), create an empty + lexical environment, otherwise, turn off lexical binding. */ + lex_bound = find_symbol_value (Qlexical_binding); + if (NILP (lex_bound) || EQ (lex_bound, Qunbound)) + specbind (Qinternal_interpreter_environment, Qnil); + else + specbind (Qinternal_interpreter_environment, Fcons (Qt, Qnil)); + GCPRO4 (sourcename, readfun, start, end); /* Try to ensure sourcename is a truename, except whilst preloading. */ @@ -1837,8 +1976,11 @@ This function preserves the position of point. */) specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); specbind (Qstandard_output, tem); + specbind (Qlexical_binding, Qnil); record_unwind_protect (save_excursion_restore, save_excursion_save ()); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); + if (lisp_file_lexically_bound_p (buf)) + Fset (Qlexical_binding, Qt); readevalloop (buf, 0, filename, Feval, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); unbind_to (count, Qnil); @@ -2481,14 +2623,8 @@ read1 (readcharfun, pch, first_in_list) invalid_syntax ("#&...", 5); } if (c == '[') - { - /* 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); - } + /* `function vector' objects, including byte-compiled functions. */ + return read_vector (readcharfun, 1); if (c == '(') { Lisp_Object tmp; @@ -3300,9 +3436,9 @@ isfloat_string (cp, ignore_trailing) static Lisp_Object -read_vector (readcharfun, bytecodeflag) +read_vector (readcharfun, read_funvec) Lisp_Object readcharfun; - int bytecodeflag; + int read_funvec; { register int i; register int size; @@ -3310,6 +3446,11 @@ read_vector (readcharfun, bytecodeflag) 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); @@ -3320,11 +3461,19 @@ read_vector (readcharfun, bytecodeflag) for (i = 0; i < size; i++) { 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 (bytecodeflag && load_force_doc_strings) + if (read_bytecode && load_force_doc_strings) { if (i == COMPILED_BYTECODE) { @@ -3377,6 +3526,14 @@ read_vector (readcharfun, bytecodeflag) tem = Fcdr (tem); 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; } @@ -3979,6 +4136,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd, sym = intern_c_string (namestring); i_fwd->type = Lisp_Fwd_Int; i_fwd->intvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); } @@ -3993,6 +4151,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd, sym = intern_c_string (namestring); b_fwd->type = Lisp_Fwd_Bool; b_fwd->boolvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); @@ -4011,6 +4170,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd, sym = intern_c_string (namestring); o_fwd->type = Lisp_Fwd_Obj; o_fwd->objvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); } @@ -4023,6 +4183,7 @@ defvar_lisp (struct Lisp_Objfwd *o_fwd, staticpro (address); } + /* Similar but define a variable whose value is the Lisp Object stored at a particular offset in the current kboard object. */ @@ -4034,6 +4195,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd, sym = intern_c_string (namestring); ko_fwd->type = Lisp_Fwd_Kboard_Obj; ko_fwd->offset = offset; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); } @@ -4463,6 +4625,16 @@ to load. See also `load-dangerous-libraries'. */); Vbytecomp_version_regexp = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); + Qlexical_binding = intern ("lexical-binding"); + staticpro (&Qlexical_binding); + DEFVAR_LISP ("lexical-binding", &Vlexical_binding, + doc: /* If non-nil, use lexical binding when evaluating code. +This only applies to code evaluated by `eval-buffer' and `eval-region'. +This variable is automatically set from the file variables of an interpreted + lisp file read using `load'. +This variable automatically becomes buffer-local when set. */); + Fmake_variable_buffer_local (Qlexical_binding); + DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list, doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; diff --git a/src/print.c b/src/print.c index 6d403e00fe..fb29823366 100644 --- a/src/print.c +++ b/src/print.c @@ -1340,7 +1340,7 @@ print_preprocess (obj) loop: if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -1543,7 +1543,7 @@ print_object (obj, printcharfun, escapeflag) /* Detect circularities and truncate them. */ if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -2175,7 +2175,7 @@ print_object (obj, printcharfun, escapeflag) else { EMACS_INT size = XVECTOR (obj)->size; - if (COMPILEDP (obj)) + if (FUNVECP (obj)) { PRINTCHAR ('#'); size &= PSEUDOVECTOR_SIZE_MASK; -- 2.20.1