This initial patch is based on 2002-06-27T22:39:10Z!storm@cua.dk of the original
lexbind branch.
* 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.
* 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
* 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
@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
@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
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
* 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
@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
@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}.
* 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.
* 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.
--- /dev/null
+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.
+
+\f
+* 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
+
+
+\f
+----------------------------------------------------------------------
+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.
+
+\f
+Local variables:
+mode: outline
+paragraph-separate: "[ \f]*$"
+end:
+
+arch-tag: d5ab31ab-2041-4b15-a1a9-e7c42693060c
--- /dev/null
+2004-05-20 Miles Bader <miles@gnu.org>
+
+ * 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
--- /dev/null
+2006-12-04 Miles Bader <miles@gnu.org>
+
+ * Makefile.in (COMPILE_FIRST_STACK_DEPTH): New variable.
+ (compile, compile-always): Use it.
+
+2005-10-24 Miles Bader <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * emacs-lisp/byte-lexbind.el (byte-compile-compute-lforminfo):
+ Look at variable's global specialp state too.
+
+2004-04-09 Miles Bader <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * emacs-lisp/lisp-mode.el (eval-last-sexp-1): Setup the lexical
+ environment if lexical-binding is enabled.
+
+2003-10-14 Miles Bader <miles@gnu.org>
+
+ * emacs-lisp/macroexp.el (macroexpand-all-1): Special-case
+ `backquote-list*' to avoid stack overflows.
+
+2003-04-04 Miles Bader <miles@gnu.org>
+
+ * help-fns.el (help-function-arglist): Handle interpreted closures.
+
+2002-11-20 Miles Bader <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ 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 <miles@gnu.org>
+
+ * 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
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.
@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
--- /dev/null
+;;; byte-lexbind.el --- Lexical binding support for byte-compiler
+;;
+;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
+;;
+;; Author: Miles Bader <miles@gnu.org>
+;; 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)))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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))
+
+\f
+;;; 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))))
+
+\f
+;;; 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
(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)
(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))))))
((>= 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))))
(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))
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
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.
;; 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
(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.
((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<deleted>" lap0)
(setq lap (delq lap0 (delq lap1 lap))))
- ((= tmp 0)
+ ((= stack-adjust 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> 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:
;;
;; 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)
;;
((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
'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:
(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)))
;;
(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
;; 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))
(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: <deleted>
;; (and other references to TAG2 are replaced with TAG1)
(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)
""))
(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
;;
(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
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
;; 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))
(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)
;; 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)
: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
;; (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
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.
(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")
(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.
;; 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))))
\f
(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
(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)
(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)))
(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.
(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))
(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).
(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
;; (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)
(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)))
(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.
(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))
+
\f
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
(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.
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)))
(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))
(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*)
(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)
(mapc 'byte-compile-form (cdr form))
(byte-compile-out 'byte-call (length (cdr (cdr form)))))
+\f
+;; 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)))))
+\f
(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
"Compiler error: `%s' has no `byte-compile-negated-op' property"
(car form)))
(cdr form))))
+
\f
;;; other tricky macro-like special-forms
(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.
;; 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"
(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)
\f
;;; call tree stuff
(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 #<subr %s>" name))
- (if (and (listp obj) (eq (car obj) 'autoload))
- (progn
- (load (nth 1 obj))
- (setq obj (symbol-function name))))
+ (when (and (listp obj) (eq (car obj) 'autoload))
+ (load (nth 1 obj))
+ (setq obj (symbol-function name)))
(if (eq (car-safe obj) 'macro) ;handle macros
(setq macro t
obj (cdr obj)))
+ (when (and (listp obj) (eq (car obj) 'closure))
+ (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)))
(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)))
(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)))))
(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))
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))
(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)))
(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)))
(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")
((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.")))))))
\f
;; Variables
(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.
--- /dev/null
+2004-05-20 Miles Bader <miles@gnu.org>
+
+ * 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
--- /dev/null
+2008-04-23 Miles Bader <miles@gnu.org>
+
+ * eval.c (Ffunctionp): Return nil for special forms.
+ (Qunevalled): New variable.
+ (syms_of_eval): Initialize it.
+
+2007-10-18 Miles Bader <miles@gnu.org>
+
+ * eval.c (FletX): Test the type of VARLIST rather than just !NILP.
+ (Flet): Use XCAR instead of Fcar.
+
+2007-10-16 Miles Bader <miles@gnu.org>
+
+ * alloc.c (make_funvec, Fpurecopy): Set the pseudo-vector type.
+
+2006-02-10 Miles Bader <miles@gnu.org>
+
+ * eval.c (Ffunctionp): Supply new 2nd arg to Findirect_function.
+
+2005-03-04 Miles Bader <miles@gnu.org>
+
+ * eval.c (FletX): Update Vinterpreter_lexical_environment for each
+ variable we bind, instead of all at once like `let'.
+
+2004-08-09 Miles Bader <miles@gnu.org>
+
+ 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 <miles@gnu.org>
+
+ * eval.c (Fspecialp): New function.
+ (syms_of_eval): Initialize it.
+
+2004-04-03 Miles Bader <miles@gnu.org>
+
+ * 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 <miles@gnu.org>
+
+ * bytecode.c (Fbyte_code): Fsub1 can GC, so protect it.
+
+2002-06-12 Miles Bader <miles@gnu.org>
+
+ 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
}
+/* 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.
}
+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,
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);
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;
}
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;
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;
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);
}
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. */
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
+ defsubr (&Sfunvec);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
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.
\f
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
#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
} 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
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
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:
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;
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))
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)
{
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);
}
}
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");
staticpro (&Qwindow);
/* staticpro (&Qsubr); */
staticpro (&Qcompiled_function);
+ staticpro (&Qfunction_vector);
staticpro (&Qbuffer);
staticpro (&Qframe);
staticpro (&Qvector);
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
+ defsubr (&Sfunvecp);
defsubr (&Schar_or_string_p);
defsubr (&Scar);
defsubr (&Scdr);
/* 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;
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.");
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
}
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. */
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;
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;
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__
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))
{
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));
(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;
}
use `called-interactively-p'. */)
()
{
- return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil;
+ return interactive_p (1) ? Qt : Qnil;
}
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)
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);
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);
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;
}
if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fset_default (sym, tem);
+ XSYMBOL (sym)->declared_special = 1;
tem = Fcar (Fcdr (Fcdr (args)));
if (!NILP (tem))
{
(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);
}
(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;
}
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);
}
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;
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))
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);
}
/* 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.
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))
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);
}
\f
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;
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)
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);
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))
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
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);
UNGCPRO;
return value;
}
+
\f
+
+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;
+}
+
+\f
+
+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);
+}
+\f
+
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. */)
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);
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);
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
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;
{
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);
}
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);
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);
}
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;
}
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++)
{
case IMAGE_FUNCTION_VALUE:
value = indirect_function (value);
if (SUBRP (value)
- || COMPILEDP (value)
+ || FUNVECP (value)
|| (CONSP (value) && EQ (XCAR (value), Qlambda)))
break;
return 0;
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'. */
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,
#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))
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)
/* 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.
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
#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 <rms@gnu.ai.mit.edu> thinks that MULE
#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)
#define FUNCTIONP(OBJ) \
((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \
|| (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \
- || COMPILEDP (OBJ) \
+ || FUNVECP (OBJ) \
|| SUBRP (OBJ))
/* defsubr (Sname);
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);
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;
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)));
/* 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;
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
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;
/* 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;
\f
+
+/* 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;
+ }
+}
+
+\f
/* 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.
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),
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);
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. */
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. */
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);
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;
\f
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;
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);
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)
{
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;
}
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);
}
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);
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);
}
staticpro (address);
}
+
/* Similar but define a variable whose value is the Lisp Object stored
at a particular offset in the current kboard object. */
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);
}
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;
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)
/* 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)
else
{
EMACS_INT size = XVECTOR (obj)->size;
- if (COMPILEDP (obj))
+ if (FUNVECP (obj))
{
PRINTCHAR ('#');
size &= PSEUDOVECTOR_SIZE_MASK;
HCoop / bpt / emacs.git / commitdiff