aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2010-06-13 16:36:17 -0400
committerStefan Monnier2010-06-13 16:36:17 -0400
commitb9598260f96ddc652cd82ab64bbe922ccfc48a29 (patch)
tree2a692a8471de07f2578ea481c99971585def8eda
parenta6e8d97c1414230e577d375c27da78c858a5fa75 (diff)
downloademacs-b9598260f96ddc652cd82ab64bbe922ccfc48a29.tar.gz
emacs-b9598260f96ddc652cd82ab64bbe922ccfc48a29.zip
New branch for lexbind, losing all history.
This initial patch is based on 2002-06-27T22:39:10Z!storm@cua.dk of the original lexbind branch.
Diffstat
-rw-r--r--doc/lispref/elisp.texi7
-rw-r--r--doc/lispref/functions.texi72
-rw-r--r--doc/lispref/objects.texi61
-rw-r--r--doc/lispref/vol1.texi2
-rw-r--r--doc/lispref/vol2.texi2
-rw-r--r--etc/NEWS.lexbind55
-rw-r--r--lisp/ChangeLog.funvec10
-rw-r--r--lisp/ChangeLog.lexbind256
-rw-r--r--lisp/Makefile.in9
-rw-r--r--lisp/emacs-lisp/byte-lexbind.el696
-rw-r--r--lisp/emacs-lisp/byte-opt.el263
-rw-r--r--lisp/emacs-lisp/bytecomp.el884
-rw-r--r--lisp/emacs-lisp/disass.el15
-rw-r--r--lisp/emacs-lisp/lisp-mode.el10
-rw-r--r--lisp/help-fns.el65
-rw-r--r--lisp/subr.el6
-rw-r--r--src/ChangeLog.funvec37
-rw-r--r--src/ChangeLog.lexbind104
-rw-r--r--src/alloc.c76
-rw-r--r--src/buffer.c1
-rw-r--r--src/bytecode.c128
-rw-r--r--src/data.c28
-rw-r--r--src/doc.c11
-rw-r--r--src/eval.c377
-rw-r--r--src/fns.c25
-rw-r--r--src/image.c2
-rw-r--r--src/keyboard.c2
-rw-r--r--src/lisp.h44
-rw-r--r--src/lread.c194
-rw-r--r--src/print.c6
30 files changed, 3032 insertions, 416 deletions
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 0f746187212..46d242fcfba 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -248,7 +248,7 @@ Programming Types
248* Macro Type:: A method of expanding an expression into another 248* Macro Type:: A method of expanding an expression into another
249 expression, more fundamental but less pretty. 249 expression, more fundamental but less pretty.
250* Primitive Function Type:: A function written in C, callable from Lisp. 250* Primitive Function Type:: A function written in C, callable from Lisp.
251* Byte-Code Type:: A function written in Lisp, then compiled. 251* Funvec Type:: A vector type callable as a function.
252* Autoload Type:: A type used for automatically loading seldom-used 252* Autoload Type:: A type used for automatically loading seldom-used
253 functions. 253 functions.
254 254
@@ -463,10 +463,11 @@ Functions
463* Inline Functions:: Defining functions that the compiler 463* Inline Functions:: Defining functions that the compiler
464 will open code. 464 will open code.
465* Declaring Functions:: Telling the compiler that a function is defined. 465* Declaring Functions:: Telling the compiler that a function is defined.
466* Function Currying:: Making wrapper functions that pre-specify
467 some arguments.
466* Function Safety:: Determining whether a function is safe to call. 468* Function Safety:: Determining whether a function is safe to call.
467* Related Topics:: Cross-references to specific Lisp primitives 469* Related Topics:: Cross-references to specific Lisp primitives
468 that have a special bearing on how 470 that have a special bearing on how functions work.
469 functions work.
470 471
471Lambda Expressions 472Lambda Expressions
472 473
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index 37e8726592a..7e8ac09b44e 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -22,7 +22,9 @@ define them.
22* Function Cells:: Accessing or setting the function definition 22* Function Cells:: Accessing or setting the function definition
23 of a symbol. 23 of a symbol.
24* Obsolete Functions:: Declaring functions obsolete. 24* Obsolete Functions:: Declaring functions obsolete.
25* Inline Functions:: Defining functions that the compiler will open code. 25* Inline Functions:: Defining functions that the compiler will open code.
26* Function Currying:: Making wrapper functions that pre-specify
27 some arguments.
26* Declaring Functions:: Telling the compiler that a function is defined. 28* Declaring Functions:: Telling the compiler that a function is defined.
27* Function Safety:: Determining whether a function is safe to call. 29* Function Safety:: Determining whether a function is safe to call.
28* Related Topics:: Cross-references to specific Lisp primitives 30* Related Topics:: Cross-references to specific Lisp primitives
@@ -111,7 +113,25 @@ editors; for Lisp programs, the distinction is normally unimportant.
111 113
112@item byte-code function 114@item byte-code function
113A @dfn{byte-code function} is a function that has been compiled by the 115A @dfn{byte-code function} is a function that has been compiled by the
114byte compiler. @xref{Byte-Code Type}. 116byte compiler. A byte-code function is actually a special case of a
117@dfn{funvec} object (see below).
118
119@item function vector
120A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose
121purpose is to define special kinds of functions. @xref{Funvec Type}.
122
123The exact meaning of the vector elements is determined by the type of
124funvec: the most common use is byte-code functions, which have a
125list---the argument list---as the first element. Further types of
126funvec object are:
127
128@table @code
129@item curry
130A curried function. Remaining arguments in the funvec are function to
131call, and arguments to prepend to user arguments at the time of the
132call; @xref{Function Currying}.
133@end table
134
115@end table 135@end table
116 136
117@defun functionp object 137@defun functionp object
@@ -152,6 +172,11 @@ function. For example:
152@end example 172@end example
153@end defun 173@end defun
154 174
175@defun funvecp object
176@code{funvecp} returns @code{t} if @var{object} is a function vector
177object (including byte-code objects), and @code{nil} otherwise.
178@end defun
179
155@defun subr-arity subr 180@defun subr-arity subr
156This function provides information about the argument list of a 181This function provides information about the argument list of a
157primitive, @var{subr}. The returned value is a pair 182primitive, @var{subr}. The returned value is a pair
@@ -1277,6 +1302,49 @@ do for macros. (@xref{Argument Evaluation}.)
1277Inline functions can be used and open-coded later on in the same file, 1302Inline functions can be used and open-coded later on in the same file,
1278following the definition, just like macros. 1303following the definition, just like macros.
1279 1304
1305@node Function Currying
1306@section Function Currying
1307@cindex function currying
1308@cindex currying
1309@cindex partial-application
1310
1311Function currying is a way to make a new function that calls an
1312existing function with a partially pre-determined argument list.
1313
1314@defun curry function &rest args
1315Return a function-like object that will append any arguments it is
1316called with to @var{args}, and call @var{function} with the resulting
1317list of arguments.
1318
1319For example, @code{(curry 'concat "The ")} returns a function that
1320concatenates @code{"The "} and its arguments. Calling this function
1321on @code{"end"} returns @code{"The end"}:
1322
1323@example
1324(funcall (curry 'concat "The ") "end")
1325 @result{} "The end"
1326@end example
1327
1328The @dfn{curried function} is useful as an argument to @code{mapcar}:
1329
1330@example
1331(mapcar (curry 'concat "The ") '("big" "red" "balloon"))
1332 @result{} ("The big" "The red" "The balloon")
1333@end example
1334@end defun
1335
1336Function currying may be implemented in any Lisp by constructing a
1337@code{lambda} expression, for instance:
1338
1339@example
1340(defun curry (function &rest args)
1341 `(lambda (&rest call-args)
1342 (apply #',function ,@@args call-args)))
1343@end example
1344
1345However in Emacs Lisp, a special curried function object is used for
1346efficiency. @xref{Funvec Type}.
1347
1280@node Declaring Functions 1348@node Declaring Functions
1281@section Telling the Compiler that a Function is Defined 1349@section Telling the Compiler that a Function is Defined
1282@cindex function declaration 1350@cindex function declaration
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 5c3ac13cdaf..1a72fdf671c 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -157,7 +157,7 @@ latter are unique to Emacs Lisp.
157* Macro Type:: A method of expanding an expression into another 157* Macro Type:: A method of expanding an expression into another
158 expression, more fundamental but less pretty. 158 expression, more fundamental but less pretty.
159* Primitive Function Type:: A function written in C, callable from Lisp. 159* Primitive Function Type:: A function written in C, callable from Lisp.
160* Byte-Code Type:: A function written in Lisp, then compiled. 160* Funvec Type:: A vector type callable as a function.
161* Autoload Type:: A type used for automatically loading seldom-used 161* Autoload Type:: A type used for automatically loading seldom-used
162 functions. 162 functions.
163@end menu 163@end menu
@@ -1315,18 +1315,55 @@ with the name of the subroutine.
1315@end group 1315@end group
1316@end example 1316@end example
1317 1317
1318@node Byte-Code Type 1318@node Funvec Type
1319@subsection Byte-Code Function Type 1319@subsection ``Function Vector' Type
1320@cindex function vector
1321@cindex funvec
1320 1322
1321The byte compiler produces @dfn{byte-code function objects}. 1323A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose
1322Internally, a byte-code function object is much like a vector; however, 1324purpose is to define special kinds of functions. You can examine or
1323the evaluator handles this data type specially when it appears as a 1325modify the contents of a funvec like a normal vector, using the
1324function to be called. @xref{Byte Compilation}, for information about 1326@code{aref} and @code{aset} functions.
1325the byte compiler.
1326 1327
1327The printed representation and read syntax for a byte-code function 1328The behavior of a funvec when called is dependent on the kind of
1328object is like that for a vector, with an additional @samp{#} before the 1329funvec it is, and that is determined by its first element (a
1329opening @samp{[}. 1330zero-length funvec will signal an error if called):
1331
1332@table @asis
1333@item A list
1334A funvec with a list as its first element is a byte-compiled function,
1335produced by the byte compiler; such funvecs are known as
1336@dfn{byte-code function objects}. @xref{Byte Compilation}, for
1337information about the byte compiler.
1338
1339@item The symbol @code{curry}
1340A funvec with @code{curry} as its first element is a ``curried function''.
1341
1342The second element in such a funvec is the function which is
1343being curried, and the remaining elements are a list of arguments.
1344
1345Calling such a funvec operates by calling the embedded function with
1346an argument list composed of the arguments in the funvec followed by
1347the arguments the funvec was called with. @xref{Function Currying}.
1348@end table
1349
1350The printed representation and read syntax for a funvec object is like
1351that for a vector, with an additional @samp{#} before the opening
1352@samp{[}.
1353
1354@defun funvecp object
1355@code{funvecp} returns @code{t} if @var{object} is a function vector
1356object (including byte-code objects), and @code{nil} otherwise.
1357@end defun
1358
1359@defun funvec kind &rest params
1360@code{funvec} returns a new function vector containing @var{kind} and
1361@var{params}. @var{kind} determines the type of funvec; it should be
1362one of the choices listed in the table above.
1363
1364Typically you should use the @code{make-byte-code} function to create
1365byte-code objects, though they are a type of funvec.
1366@end defun
1330 1367
1331@node Autoload Type 1368@node Autoload Type
1332@subsection Autoload Type 1369@subsection Autoload Type
@@ -1773,7 +1810,7 @@ with references to further information.
1773@xref{Buffer Basics, bufferp}. 1810@xref{Buffer Basics, bufferp}.
1774 1811
1775@item byte-code-function-p 1812@item byte-code-function-p
1776@xref{Byte-Code Type, byte-code-function-p}. 1813@xref{Funvec Type, byte-code-function-p}.
1777 1814
1778@item case-table-p 1815@item case-table-p
1779@xref{Case Tables, case-table-p}. 1816@xref{Case Tables, case-table-p}.
diff --git a/doc/lispref/vol1.texi b/doc/lispref/vol1.texi
index a0590c3d282..052d83eacd7 100644
--- a/doc/lispref/vol1.texi
+++ b/doc/lispref/vol1.texi
@@ -268,7 +268,7 @@ Programming Types
268* Macro Type:: A method of expanding an expression into another 268* Macro Type:: A method of expanding an expression into another
269 expression, more fundamental but less pretty. 269 expression, more fundamental but less pretty.
270* Primitive Function Type:: A function written in C, callable from Lisp. 270* Primitive Function Type:: A function written in C, callable from Lisp.
271* Byte-Code Type:: A function written in Lisp, then compiled. 271* Funvec Type:: A vector type callable as a function.
272* Autoload Type:: A type used for automatically loading seldom-used 272* Autoload Type:: A type used for automatically loading seldom-used
273 functions. 273 functions.
274 274
diff --git a/doc/lispref/vol2.texi b/doc/lispref/vol2.texi
index ad4c74611a8..d6358f3ecfc 100644
--- a/doc/lispref/vol2.texi
+++ b/doc/lispref/vol2.texi
@@ -267,7 +267,7 @@ Programming Types
267* Macro Type:: A method of expanding an expression into another 267* Macro Type:: A method of expanding an expression into another
268 expression, more fundamental but less pretty. 268 expression, more fundamental but less pretty.
269* Primitive Function Type:: A function written in C, callable from Lisp. 269* Primitive Function Type:: A function written in C, callable from Lisp.
270* Byte-Code Type:: A function written in Lisp, then compiled. 270* Funvec Type:: A vector type callable as a function.
271* Autoload Type:: A type used for automatically loading seldom-used 271* Autoload Type:: A type used for automatically loading seldom-used
272 functions. 272 functions.
273 273
diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind
new file mode 100644
index 00000000000..372ee6827cf
--- /dev/null
+++ b/etc/NEWS.lexbind
@@ -0,0 +1,55 @@
1GNU Emacs NEWS -- history of user-visible changes.
2
3Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
4 Free Software Foundation, Inc.
5See the end of the file for license conditions.
6
7Please send Emacs bug reports to bug-gnu-emacs@gnu.org.
8If possible, use M-x report-emacs-bug.
9
10This file is about changes in the Emacs "lexbind" branch.
11
12
13* Lisp changes in Emacs 23.1
14
15** New `function vector' type, including function currying
16The `function vector', or `funvec' type extends the old
17byte-compiled-function vector type to have other uses as well, and
18includes existing byte-compiled functions as a special case. The kind
19of funvec is determined by the first element: a list is a byte-compiled
20function, and a non-nil atom is one of the new extended uses, currently
21`curry' for curried functions. See the node `Funvec Type' in the Emacs
22Lisp Reference Manual for more information.
23
24*** New function curry allows constructing `curried functions'
25(see the node `Function Currying' in the Emacs Lisp Reference Manual).
26
27*** New functions funvec and funvecp allow primitive access to funvecs
28
29
30
31----------------------------------------------------------------------
32This file is part of GNU Emacs.
33
34GNU Emacs is free software; you can redistribute it and/or modify
35it under the terms of the GNU General Public License as published by
36the Free Software Foundation; either version 2, or (at your option)
37any later version.
38
39GNU Emacs is distributed in the hope that it will be useful,
40but WITHOUT ANY WARRANTY; without even the implied warranty of
41MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
42GNU General Public License for more details.
43
44You should have received a copy of the GNU General Public License
45along with GNU Emacs; see the file COPYING. If not, write to the
46Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
47Boston, MA 02110-1301, USA.
48
49
50Local variables:
51mode: outline
52paragraph-separate: "[ ]*$"
53end:
54
55arch-tag: d5ab31ab-2041-4b15-a1a9-e7c42693060c
diff --git a/lisp/ChangeLog.funvec b/lisp/ChangeLog.funvec
new file mode 100644
index 00000000000..0a31b9a590f
--- /dev/null
+++ b/lisp/ChangeLog.funvec
@@ -0,0 +1,10 @@
12004-05-20 Miles Bader <miles@gnu.org>
2
3 * subr.el (functionp): Use `funvecp' instead of
4 `byte-compiled-function-p'.
5 * help-fns.el (describe-function-1): Describe curried functions
6 and other funvecs as such.
7 (help-highlight-arguments): Only format things that look like a
8 function.
9
10;; arch-tag: 87f75aac-de53-40d7-96c7-3befaa771cb1
diff --git a/lisp/ChangeLog.lexbind b/lisp/ChangeLog.lexbind
new file mode 100644
index 00000000000..ca491f961d7
--- /dev/null
+++ b/lisp/ChangeLog.lexbind
@@ -0,0 +1,256 @@
12006-12-04 Miles Bader <miles@gnu.org>
2
3 * Makefile.in (COMPILE_FIRST_STACK_DEPTH): New variable.
4 (compile, compile-always): Use it.
5
62005-10-24 Miles Bader <miles@gnu.org>
7
8 * subr.el (functionp): Re-remove.
9
10 * emacs-lisp/bytecomp.el (byte-compile-closure): Add optional
11 ADD-LAMBDA argument, which we just pass to `byte-compile-lambda'.
12 (byte-compile-defun): Use ADD-LAMBDA arg to `byte-compile-closure'
13 instead of adding lambda ourselves.
14
152004-08-09 Miles Bader <miles@gnu.org>
16
17 Changes from merging the funvec patch:
18
19 * emacs-lisp/bytecomp.el (byte-compile-make-closure): Use `curry'
20 instead of `vector' to create compiled closures.
21
22 Merge funvec patch.
23
242004-04-29 Miles Bader <miles@gnu.org>
25
26 * emacs-lisp/bytecomp.el (byte-compile-top-level): Add new entries
27 to `byte-compile-lexical-environment' at the start, not end.
28 (byte-compile-delay-out): Correctly default STACK-ADJUST to zero.
29
30 * emacs-lisp/byte-opt.el (byte-opt-update-stack-params): Don't
31 crash on no-op lapcode entries (car is nil).
32
33 * emacs-lisp/byte-lexbind.el (byte-compile-make-lambda-lexenv):
34 Push a lexvar onto lexenv, not a vinfo!
35
362004-04-11 Miles Bader <miles@gnu.org>
37
38 * emacs-lisp/bytecomp.el (byte-compile-top-level): Correctly
39 analyze lexically-bound arguments.
40
41 * emacs-lisp/byte-lexbind.el (byte-compile-lforminfo-analyze):
42 Use `append' instead of `nconc'.
43
44 * emacs-lisp/byte-lexbind.el (byte-compile-make-lvarinfo): Don't
45 use backquote to make a mutable data-structure.
46 (byte-compile-lvarinfo-num-refs, byte-compile-lvarinfo-num-sets):
47 Renamed to use `num-' instead of `num'.
48 (byte-compile-make-lambda-lexenv): Adjusted accordingly.
49
502004-04-10 Miles Bader <miles@gnu.org>
51
52 * emacs-lisp/byte-lexbind.el (byte-compile-compute-lforminfo):
53 Look at variable's global specialp state too.
54
552004-04-09 Miles Bader <miles@gnu.org>
56
57 * emacs-lisp/byte-opt.el (byte-optimize-lapcode): Default
58 initial-stack-depth to 0.
59 (byte-optimize-lapcode): Discard the right number of values in
60 the stack-set+discard-->discard optimization.
61
622004-04-02 Miles Bader <miles@gnu.org>
63
64 * emacs-lisp/lisp-mode.el (eval-last-sexp-1): Setup the lexical
65 environment if lexical-binding is enabled.
66
672003-10-14 Miles Bader <miles@gnu.org>
68
69 * emacs-lisp/macroexp.el (macroexpand-all-1): Special-case
70 `backquote-list*' to avoid stack overflows.
71
722003-04-04 Miles Bader <miles@gnu.org>
73
74 * help-fns.el (help-function-arglist): Handle interpreted closures.
75
762002-11-20 Miles Bader <miles@gnu.org>
77
78 * emacs-lisp/bytecomp.el (byte-compile-stack-adjustment):
79 Correctly handle discardN* operators.
80 * emacs-lisp/byte-opt.el (byte-optimize-lapcode): Fix stack-depth
81 tracking errors.
82
832002-08-26 Miles Bader <miles@gnu.org>
84
85 * international/mule.el (make-char): Macroexpand call to
86 charset-id constructed by `byte-compile' hook.
87
88 * emacs-lisp/macroexp.el (macroexpand-all-1): Expand defconst value.
89
90 * emacs-lisp/byte-opt.el (byte-opt-update-stack-params): New macro.
91 (byte-optimize-lapcode): Keep track of stack-depth in final pass too.
92 Add more optimizations for lexical binding.
93 (byte-compile-inline-expand): Macroexpand result of inlining.
94
95 * emacs-lisp/bytecomp.el (byte-compile-lambda): Update call to
96 byte-compile-closure-initial-lexenv-p.
97 (byte-discardN-preserve-tos): Alias to byte-discardN.
98 (byte-compile-push-binding-init): Don't push unused variables on
99 init-lexenv.
100 (byte-compile-push-binding-init): Don't use LFORMINFO if it's nil.
101 (byte-compile-lambda): Don't look at lexical environment unless
102 we're using lexical binding.
103 (byte-compile-defmacro): Correctly generate macros.
104
105 * emacs-lisp/byte-lexbind.el (byte-compile-unbind): Optimize the
106 dynamic-bindings-only case.
107 (byte-compile-bind): Don't special-case unused lexical variables.
108
109 * emacs-lisp/disass.el (disassemble-1): Print arg for discardN ops.
110
1112002-08-19 Miles Bader <miles@gnu.org>
112
113 * emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Handle
114 `byte-discardN-preserve-tos' pseudo-op.
115 (byte-compile-side-effect-and-error-free-ops): Add `byte-stack-ref'.
116 (byte-compile-side-effect-free-ops): Add `byte-vec-ref'.
117 (byte-optimize-lapcode): Add some cases for stack-set/ref ops.
118 Add tracking of stack-depth. Unfinished code to collapse
119 lexical-unbinding sequences.
120
121 * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle
122 `byte-discardN-preserve-tos' pseudo-op.
123 (byte-compile-top-level): If there are lexical args, output a TAG
124 op to record the initial stack-depth for the optimizer.
125
1262002-08-17 Miles Bader <miles@gnu.org>
127
128 * emacs-lisp/bytecomp.el (byte-discardN): Add byte-defop.
129 (byte-compile-lapcode): Include byte-discardN.
130 (byte-compile-lambda): Fixup closure detection.
131 (byte-compile-top-level): Handle arguments for a lexical lambda.
132 (byte-compile-lexical-variable-ref, byte-compile-variable-ref)
133 (byte-compile-variable-set): Use byte-compile-stack-set/ref.
134 (byte-compile-discard): Add new parameters NUM and PRESERVE-TOS.
135 (byte-compile-stack-ref, byte-compile-stack-set): New functions.
136 (byte-compile-push-binding-init): Get the variable list properly
137 from LFORMINFO.
138
139 * emacs-lisp/byte-lexbind.el (byte-compile-lforminfo-analyze):
140 Ignore setq'd variables we're not interested in.
141 (byte-compile-make-lambda-lexenv): Add assertion that closed-over
142 variables be heap allocated.
143 (byte-compile-closure-initial-lexenv-p): Renamed from
144 byte-compile-closure-lexenv-p.
145 (byte-compile-non-stack-bindings-p): Get the variable list
146 properly from LFORMINFO.
147 (byte-compile-maybe-push-heap-environment): Handle the
148 no-closed-over-variables case correctly.
149 (byte-compile-bind): Use byte-compile-stack-set/ref.
150 Don't bother modifying INIT-LEXENV as no one will see the changes.
151 (byte-compile-unbind): Call `byte-compile-discard' to handle
152 unbinding lexical bindings.
153
154 * emacs-lisp/disass.el (disassemble-internal): Handle closures.
155 (disassemble-1): Handle new bytecodes.
156 * emacs-lisp/byte-opt.el (disassemble-offset): Handle new bytecodes.
157
1582002-06-16 Miles Bader <miles@gnu.org>
159
160 * emacs-lisp/macroexp.el (macroexp-accumulate): New macro.
161 (macroexpand-all-forms, macroexpand-all-clauses): Use it.
162 * Makefile.in (compile): Undo previous change.
163
1642002-06-14 Miles Bader <miles@gnu.org>
165
166 * Makefile.in (COMPILE_FIRST): Add `emacs-lisp/macroexp.el'.
167 (compile): Add a special case that compiles `emacs-lisp/macroexp.el'
168 with an increased max-lisp-eval-depth.
169
170 * emacs-lisp/bytecomp.el: Provide `bytecomp-preload', at the
171 beginning of the file. Require `byte-lexbind' at compile time.
172 Add a few doc string.
173 (byte-compile-push-bytecodes)
174 (byte-compile-push-bytecode-const2): New macros.
175 (byte-compile-lapcode): Use them. Do general code cleanup.
176 (byte-compile-initial-macro-environment): Expand macros in
177 byte-compile-eval before passing to byte-compile-top-level.
178 (byte-compile): Use the `byte-compile-initial-macro-environment'.
179
180 * emacs-lisp/byte-lexbind.el: Require `bytecomp-preload' instead of
181 `bytecomp'.
182 (byte-compile-bind): Use `byte-compile-dynamic-variable-bind' to bind
183 dynamic variables.
184 (byte-compile-maybe-push-heap-environment): Fix function name typo.
185
1862002-06-13 Miles Bader <miles@gnu.org>
187
188 Byte compiler lexical binding support (not finished yet):
189 * emacs-lisp/bytecomp.el: Require `macroexp'.
190 (byte-compile-lexical-environment)
191 (byte-compile-current-heap-environment)
192 (byte-compile-current-num-closures): New variables.
193 (0, 178, 179, 180, 181): New byte-opcodes.
194 (byte-compile-lapcode): Handle stack-ref/set opcodes. Signal an
195 error if a delay-output placeholder is not filled in yet.
196 (byte-compile-file-form, byte-compile): Expand all macros with
197 `macroexpand-all'.
198 (byte-compile-file-form-defsubst, byte-compile-form): Don't expand
199 macros here.
200 (byte-compile-make-lambda-lexenv): Autoload.
201 (byte-compile-lambda): Initial code for handling lexically-bound
202 arguments and closures; doesn't work yet.
203 (byte-compile-closure-code-p, byte-compile-make-closure)
204 (byte-compile-closure): New functions.
205 (byte-compile-check-variable, byte-compile-dynamic-variable-op)
206 (byte-compile-dynamic-variable-bind)
207 (byte-compile-lexical-variable-ref, byte-compile-variable-set):
208 New functions.
209 (byte-compile-variable-ref): Remove second argument. Now only
210 handles real variable references (not setting or binding).
211 (byte-compile-push-unknown-constant)
212 (byte-compile-resolve-unknown-constant): New functions.
213 (byte-compile-funarg, byte-compile-funarg-2): Functions removed.
214 (byte-compile-function-form): Use either `byte-compile-constant'
215 or `byte-compile-closure'.
216 (byte-compile-setq): Use `byte-compile-variable-set' instead of
217 `byte-compile-variable-ref'.
218 (apply, mapcar, mapatoms, mapconcat, mapc, sort):
219 `byte-defop-compiler-1's removed.
220 (byte-compile-while): Make sure lexically-bound variables inside
221 the loop don't get stored in an environment outside the loop.
222 (byte-compile-compute-lforminfo): Autoload.
223 (byte-compile-push-binding-init): New function.
224 (byte-compile-let, byte-compile-let*): Handle lexical binding.
225 (byte-compile-defun): Use `byte-compile-closure' to do the work.
226 (byte-compile-defmacro): Use `byte-compile-make-closure'.
227 (byte-compile-defvar): Expand the generated call to `push' since
228 we're past macroexpansion already.
229 (byte-compile-stack-adjustment): New function.
230 (byte-compile-out): Make second arg optional. Rewrite for clarity.
231 (byte-compile-delay-out, byte-compile-delayed-out): New functions.
232
233 * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't
234 expand macros here.
235
236 * emacs-lisp/macroexp.el (macroexpand-all-1): Expand defmacro forms.
237
238 * emacs-lisp/byte-lexbind.el (byte-compile-make-lvarinfo)
239 (byte-compile-lforminfo-add-var)
240 (byte-compile-lforminfo-note-closure)
241 (byte-compile-compute-lforminfo)
242 (byte-compile-lforminfo-from-lambda)
243 (byte-compile-lforminfo-analyze)
244 (byte-compile-heapenv-add-accessible-env)
245 (byte-compile-heapenv-ensure-access)
246 (byte-compile-rearrange-let-clauses, byte-compile-bind)
247 (byte-compile-unbind): Fix a bunch of typos.
248
2492002-06-12 Miles Bader <miles@gnu.org>
250
251 * emacs-lisp/byte-lexbind.el, emacs-lisp/macroexp.el: New files.
252
253 * subr.el (functionp): Function removed (now a subr).
254 * help-fns.el (describe-function-1): Handle interpreted closures.
255
256;; arch-tag: bd1b5b8b-fdb2-425d-9ac2-20689fb0ee70
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 4effdddff6a..25f7b89c9db 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -71,6 +71,13 @@ AUTOGENEL = loaddefs.el \
71 cedet/ede/loaddefs.el \ 71 cedet/ede/loaddefs.el \
72 cedet/srecode/loaddefs.el 72 cedet/srecode/loaddefs.el
73 73
74# Value of max-lisp-eval-depth when compiling initially.
75# During bootstrapping the byte-compiler is run interpreted when compiling
76# itself, and uses more stack than usual.
77#
78BIG_STACK_DEPTH = 1000
79BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
80
74# Files to compile before others during a bootstrap. This is done to 81# Files to compile before others during a bootstrap. This is done to
75# speed up the bootstrap process. 82# speed up the bootstrap process.
76 83
@@ -195,7 +202,7 @@ compile-onefile:
195 @echo Compiling $(THEFILE) 202 @echo Compiling $(THEFILE)
196 @# Use byte-compile-refresh-preloaded to try and work around some of 203 @# Use byte-compile-refresh-preloaded to try and work around some of
197 @# the most common bootstrapping problems. 204 @# the most common bootstrapping problems.
198 @$(emacs) -l bytecomp -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE) 205 @$(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE)
199 206
200# Files MUST be compiled one by one. If we compile several files in a 207# Files MUST be compiled one by one. If we compile several files in a
201# row (i.e., in the same instance of Emacs) we can't make sure that 208# row (i.e., in the same instance of Emacs) we can't make sure that
diff --git a/lisp/emacs-lisp/byte-lexbind.el b/lisp/emacs-lisp/byte-lexbind.el
new file mode 100644
index 00000000000..a01829abf50
--- /dev/null
+++ b/lisp/emacs-lisp/byte-lexbind.el
@@ -0,0 +1,696 @@
1;;; byte-lexbind.el --- Lexical binding support for byte-compiler
2;;
3;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
4;;
5;; Author: Miles Bader <miles@gnu.org>
6;; Keywords: lisp, compiler, lexical binding
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26;;
27
28;;; Code:
29
30(require 'bytecomp-preload "bytecomp")
31
32;; Downward closures aren't implemented yet, so this should always be nil
33(defconst byte-compile-use-downward-closures nil
34 "If true, use `downward closures', which are closures that don't cons.")
35
36(defconst byte-compile-save-window-excursion-uses-eval t
37 "If true, the bytecode for `save-window-excursion' uses eval.
38This means that the body of the form must be put into a closure.")
39
40(defun byte-compile-arglist-vars (arglist)
41 "Return a list of the variables in the lambda argument list ARGLIST."
42 (remq '&rest (remq '&optional arglist)))
43
44
45;;; Variable extent analysis.
46
47;; A `lforminfo' holds information about lexical bindings in a form, and some
48;; other info for analysis. It is a cons-cell, where the car is a list of
49;; `lvarinfo' stuctures, which form an alist indexed by variable name, and the
50;; cdr is the number of closures found in the form:
51;;
52;; LFORMINFO : ((LVARINFO ...) . NUM-CLOSURES)"
53;;
54;; A `lvarinfo' holds information about a single lexical variable. It is a
55;; list whose car is the variable name (so an lvarinfo is suitable as an alist
56;; entry), and the rest of the of which holds information about the variable:
57;;
58;; LVARINFO : (VAR NUM-REFS NUM-SETS CLOSED-OVER)
59;;
60;; NUM-REFS is the number of times the variable's value is used
61;; NUM-SETS is the number of times the variable's value is set
62;; CLOSED-OVER is non-nil if the variable is referenced
63;; anywhere but in its original function-level"
64
65;;; lvarinfo:
66
67;; constructor
68(defsubst byte-compile-make-lvarinfo (var &optional already-set)
69 (list var 0 (if already-set 1 0) 0 nil))
70;; accessors
71(defsubst byte-compile-lvarinfo-var (vinfo) (car vinfo))
72(defsubst byte-compile-lvarinfo-num-refs (vinfo) (cadr vinfo))
73(defsubst byte-compile-lvarinfo-num-sets (vinfo) (nth 3 vinfo))
74(defsubst byte-compile-lvarinfo-closed-over-p (vinfo) (nth 4 vinfo))
75;; setters
76(defsubst byte-compile-lvarinfo-note-ref (vinfo)
77 (setcar (cdr vinfo) (1+ (cadr vinfo))))
78(defsubst byte-compile-lvarinfo-note-set (vinfo)
79 (setcar (cddr vinfo) (1+ (nth 3 vinfo))))
80(defsubst byte-compile-lvarinfo-note-closure (vinfo)
81 (setcar (nthcdr 4 vinfo) t))
82
83;;; lforminfo:
84
85;; constructor
86(defsubst byte-compile-make-lforminfo ()
87 (cons nil 0))
88;; accessors
89(defalias 'byte-compile-lforminfo-vars 'car)
90(defalias 'byte-compile-lforminfo-num-closures 'cdr)
91;; setters
92(defsubst byte-compile-lforminfo-add-var (finfo var &optional already-set)
93 (setcar finfo (cons (byte-compile-make-lvarinfo var already-set)
94 (car finfo))))
95
96(defun byte-compile-lforminfo-make-closure-flag ()
97 "Return a new `closure-flag'."
98 (cons nil nil))
99
100(defsubst byte-compile-lforminfo-note-closure (lforminfo lvarinfo closure-flag)
101 "If a variable reference or definition is inside a closure, record that fact.
102LFORMINFO describes the form currently being analyzed, and LVARINFO
103describes the variable. CLOSURE-FLAG is either nil, if currently _not_
104inside a closure, and otherwise a `closure flag' returned by
105`byte-compile-lforminfo-make-closure-flag'."
106 (when closure-flag
107 (byte-compile-lvarinfo-note-closure lvarinfo)
108 (unless (car closure-flag)
109 (setcdr lforminfo (1+ (cdr lforminfo)))
110 (setcar closure-flag t))))
111
112(defun byte-compile-compute-lforminfo (form &optional special)
113 "Return information about variables lexically bound by FORM.
114SPECIAL is a list of variables that are special, and so shouldn't be
115bound lexically (in addition to variable that are considered special
116because they are declared with `defvar', et al).
117
118The result is an `lforminfo' data structure."
119 (and
120 (consp form)
121 (let ((lforminfo (byte-compile-make-lforminfo)))
122 (cond ((eq (car form) 'let)
123 ;; Find the bound variables
124 (dolist (clause (cadr form))
125 (let ((var (if (consp clause) (car clause) clause)))
126 (unless (or (specialp var) (memq var special))
127 (byte-compile-lforminfo-add-var lforminfo var t))))
128 ;; Analyze the body
129 (unless (null (byte-compile-lforminfo-vars lforminfo))
130 (byte-compile-lforminfo-analyze-forms lforminfo form 2
131 special nil)))
132 ((eq (car form) 'let*)
133 (dolist (clause (cadr form))
134 (let ((var (if (consp clause) (car clause) clause)))
135 ;; Analyze each initializer based on the previously
136 ;; bound variables.
137 (when (and (consp clause) lforminfo)
138 (byte-compile-lforminfo-analyze lforminfo (cadr clause)
139 special nil))
140 (unless (or (specialp var) (memq var special))
141 (byte-compile-lforminfo-add-var lforminfo var t))))
142 ;; Analyze the body
143 (unless (null (byte-compile-lforminfo-vars lforminfo))
144 (byte-compile-lforminfo-analyze-forms lforminfo form 2
145 special nil)))
146 ((eq (car form) 'condition-case)
147 ;; `condition-case' currently must dynamically bind the
148 ;; error variable, so do nothing.
149 )
150 ((memq (car form) '(defun defmacro))
151 (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special))
152 ((eq (car form) 'lambda)
153 (byte-compile-lforminfo-from-lambda lforminfo form special))
154 ((and (consp (car form)) (eq (caar form) 'lambda))
155 ;; An embedded lambda, which is basically just a `let'
156 (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special)))
157 (if (byte-compile-lforminfo-vars lforminfo)
158 lforminfo
159 nil))))
160
161(defun byte-compile-lforminfo-from-lambda (lforminfo lambda special)
162 "Initialize LFORMINFO from the lambda expression LAMBDA.
163SPECIAL is a list of variables to ignore.
164The first element of LAMBDA is ignored; it need not actually be `lambda'."
165 ;; Add the arguments
166 (dolist (arg (byte-compile-arglist-vars (cadr lambda)))
167 (byte-compile-lforminfo-add-var lforminfo arg t))
168 ;; Analyze the body
169 (unless (null (byte-compile-lforminfo-vars lforminfo))
170 (byte-compile-lforminfo-analyze-forms lforminfo lambda 2 special nil)))
171
172(defun byte-compile-lforminfo-analyze (lforminfo form &optional ignore closure-flag)
173 "Update variable information in LFORMINFO by analyzing FORM.
174IGNORE is a list of variables that shouldn't be analyzed (usually because
175they're special, or because some inner binding shadows the version in
176LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created
177with `byte-compile-lforminfo-make-closure-flag'; the latter indicates that
178FORM is inside a lambda expression that may close over some variable in
179LFORMINFO."
180 (cond ((symbolp form)
181 ;; variable reference
182 (unless (member form ignore)
183 (let ((vinfo (assq form (byte-compile-lforminfo-vars lforminfo))))
184 (when vinfo
185 (byte-compile-lvarinfo-note-ref vinfo)
186 (byte-compile-lforminfo-note-closure lforminfo vinfo
187 closure-flag)))))
188 ;; function call/special form
189 ((consp form)
190 (let ((fun (car form)))
191 (cond
192 ((eq fun 'setq)
193 (pop form)
194 (while form
195 (let ((var (pop form)))
196 (byte-compile-lforminfo-analyze lforminfo (pop form)
197 ignore closure-flag)
198 (unless (member var ignore)
199 (let ((vinfo
200 (assq var (byte-compile-lforminfo-vars lforminfo))))
201 (when vinfo
202 (byte-compile-lvarinfo-note-set vinfo)
203 (byte-compile-lforminfo-note-closure lforminfo vinfo
204 closure-flag)))))))
205 ((eq fun 'catch)
206 ;; tag
207 (byte-compile-lforminfo-analyze lforminfo (cadr form)
208 ignore closure-flag)
209 ;; `catch' uses a closure for the body
210 (byte-compile-lforminfo-analyze-forms
211 lforminfo form 2
212 ignore
213 (or closure-flag
214 (and (not byte-compile-use-downward-closures)
215 (byte-compile-lforminfo-make-closure-flag)))))
216 ((eq fun 'cond)
217 (byte-compile-lforminfo-analyze-clauses lforminfo (cdr form) 0
218 ignore closure-flag))
219 ((eq fun 'condition-case)
220 ;; `condition-case' separates its body/handlers into
221 ;; separate closures.
222 (unless (or closure-flag byte-compile-use-downward-closures)
223 ;; condition case is implemented by calling a function
224 (setq closure-flag (byte-compile-lforminfo-make-closure-flag)))
225 ;; value form
226 (byte-compile-lforminfo-analyze lforminfo (nth 2 form)
227 ignore closure-flag)
228 ;; the error variable is always bound dynamically (because
229 ;; of the implementation)
230 (when (cadr form)
231 (push (cadr form) ignore))
232 ;; handlers
233 (byte-compile-lforminfo-analyze-clauses lforminfo
234 (nthcdr 2 form) 1
235 ignore closure-flag))
236 ((eq fun '(defvar defconst))
237 (byte-compile-lforminfo-analyze lforminfo (nth 2 form)
238 ignore closure-flag))
239 ((memq fun '(defun defmacro))
240 (byte-compile-lforminfo-analyze-forms lforminfo form 3
241 ignore closure-flag))
242 ((eq fun 'function)
243 ;; Analyze an embedded lambda expression [note: we only recognize
244 ;; it within (function ...) as the (lambda ...) for is actually a
245 ;; macro returning (function (lambda ...))].
246 (when (and (consp (cadr form)) (eq (car (cadr form)) 'lambda))
247 ;; shadow bound variables
248 (setq ignore
249 (append (byte-compile-arglist-vars (cadr (cadr form)))
250 ignore))
251 ;; analyze body of lambda
252 (byte-compile-lforminfo-analyze-forms
253 lforminfo (cadr form) 2
254 ignore
255 (or closure-flag
256 (byte-compile-lforminfo-make-closure-flag)))))
257 ((eq fun 'let)
258 ;; analyze variable inits
259 (byte-compile-lforminfo-analyze-clauses lforminfo (cadr form) 1
260 ignore closure-flag)
261 ;; shadow bound variables
262 (dolist (clause (cadr form))
263 (push (if (symbolp clause) clause (car clause))
264 ignore))
265 ;; analyze body
266 (byte-compile-lforminfo-analyze-forms lforminfo form 2
267 ignore closure-flag))
268 ((eq fun 'let*)
269 (dolist (clause (cadr form))
270 (if (symbolp clause)
271 ;; shadow bound (to nil) variable
272 (push clause ignore)
273 ;; analyze variable init
274 (byte-compile-lforminfo-analyze lforminfo (cadr clause)
275 ignore closure-flag)
276 ;; shadow bound variable
277 (push (car clause) ignore)))
278 ;; analyze body
279 (byte-compile-lforminfo-analyze-forms lforminfo form 2
280 ignore closure-flag))
281 ((eq fun 'quote)
282 ;; do nothing
283 )
284 ((eq fun 'save-window-excursion)
285 ;; `save-window-excursion' currently uses a funny implementation
286 ;; that requires its body forms be put into a closure (it should
287 ;; be fixed to work more like `save-excursion' etc., do).
288 (byte-compile-lforminfo-analyze-forms
289 lforminfo form 2
290 ignore
291 (or closure-flag
292 (and byte-compile-save-window-excursion-uses-eval
293 (not byte-compile-use-downward-closures)
294 (byte-compile-lforminfo-make-closure-flag)))))
295 ((and (consp fun) (eq (car fun) 'lambda))
296 ;; Embedded lambda. These are inlined by the compiler, so
297 ;; we don't treat them like a real closure, more like `let'.
298 ;; analyze inits
299 (byte-compile-lforminfo-analyze-forms lforminfo form 2
300 ignore closure-flag)
301
302 ;; shadow bound variables
303 (setq ignore (nconc (byte-compile-arglist-vars (cadr fun))
304 ignore))
305 ;; analyze body
306 (byte-compile-lforminfo-analyze-forms lforminfo fun 2
307 ignore closure-flag))
308 (t
309 ;; For everything else, we just expand each argument (for
310 ;; setq/setq-default this works alright because the
311 ;; variable names are symbols).
312 (byte-compile-lforminfo-analyze-forms lforminfo form 1
313 ignore closure-flag)))))))
314
315(defun byte-compile-lforminfo-analyze-forms
316 (lforminfo forms skip ignore closure-flag)
317 "Update variable information in LFORMINFO by analyzing each form in FORMS.
318The first SKIP elements of FORMS are skipped without analysis. IGNORE
319is a list of variables that shouldn't be analyzed (usually because
320they're special, or because some inner binding shadows the version in
321LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created with
322`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is
323inside a lambda expression that may close over some variable in LFORMINFO."
324 (when skip
325 (setq forms (nthcdr skip forms)))
326 (while forms
327 (byte-compile-lforminfo-analyze lforminfo (pop forms)
328 ignore closure-flag)))
329
330(defun byte-compile-lforminfo-analyze-clauses
331 (lforminfo clauses skip ignore closure-flag)
332 "Update variable information in LFORMINFO by analyzing each clause in CLAUSES.
333Each clause is a list of forms; any clause that's not a list is ignored. The
334first SKIP elements of each clause are skipped without analysis. IGNORE is a
335list of variables that shouldn't be analyzed (usually because they're special,
336or because some inner binding shadows the version in LFORMINFO).
337CLOSURE-FLAG should be either nil or a `closure flag' created with
338`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is
339inside a lambda expression that may close over some variable in LFORMINFO."
340 (while clauses
341 (let ((clause (pop clauses)))
342 (when (consp clause)
343 (byte-compile-lforminfo-analyze-forms lforminfo clause skip
344 ignore closure-flag)))))
345
346
347;;; Lexical environments
348
349;; A lexical environment is an alist, where each element is of the form
350;; (VAR . (OFFSET . ENV)) where VAR is either a symbol, for normal
351;; variables, or an `heapenv' descriptor for references to heap environment
352;; vectors. ENV is either an atom, meaning a `stack allocated' variable
353;; (the particular atom serves to indicate the particular function context
354;; on whose stack it's allocated), or an `heapenv' descriptor (see above),
355;; meaning a variable allocated in a heap environment vector. For the
356;; later case, an anonymous `variable' holding a pointer to the environment
357;; vector may be located by recursively looking up ENV in the environment
358;; as if it were a variable (so the entry for that `variable' will have a
359;; non-symbol VAR).
360
361;; We call a lexical environment a `lexenv', and an entry in it a `lexvar'.
362
363;; constructor
364(defsubst byte-compile-make-lexvar (name offset &optional env)
365 (cons name (cons offset env)))
366;; accessors
367(defsubst byte-compile-lexvar-name (lexvar) (car lexvar))
368(defsubst byte-compile-lexvar-offset (lexvar) (cadr lexvar))
369(defsubst byte-compile-lexvar-environment (lexvar) (cddr lexvar))
370(defsubst byte-compile-lexvar-variable-p (lexvar) (symbolp (car lexvar)))
371(defsubst byte-compile-lexvar-environment-p (lexvar)
372 (not (symbolp (car lexvar))))
373(defsubst byte-compile-lexvar-on-stack-p (lexvar)
374 (atom (byte-compile-lexvar-environment lexvar)))
375(defsubst byte-compile-lexvar-in-heap-p (lexvar)
376 (not (byte-compile-lexvar-on-stack-p lexvar)))
377
378(defun byte-compile-make-lambda-lexenv (form closed-over-lexenv)
379 "Return a new lexical environment for a lambda expression FORM.
380CLOSED-OVER-LEXENV is the lexical environment in which FORM occurs.
381The returned lexical environment contains two sets of variables:
382 * Variables that were in CLOSED-OVER-LEXENV and used by FORM
383 (all of these will be `heap' variables)
384 * Arguments to FORM (all of these will be `stack' variables)."
385 ;; See if this is a closure or not
386 (let ((closure nil)
387 (lforminfo (byte-compile-make-lforminfo))
388 (args (byte-compile-arglist-vars (cadr form))))
389 ;; Add variables from surrounding lexical environment to analysis set
390 (dolist (lexvar closed-over-lexenv)
391 (when (and (byte-compile-lexvar-in-heap-p lexvar)
392 (not (memq (car lexvar) args)))
393 ;; The variable is located in a heap-allocated environment
394 ;; vector, so FORM may use it. Add it to the set of variables
395 ;; that we'll search for in FORM.
396 (byte-compile-lforminfo-add-var lforminfo (car lexvar))))
397 ;; See how FORM uses these potentially closed-over variables.
398 (byte-compile-lforminfo-analyze lforminfo form args)
399 (let ((lexenv nil))
400 (dolist (vinfo (byte-compile-lforminfo-vars lforminfo))
401 (when (> (byte-compile-lvarinfo-num-refs vinfo) 0)
402 ;; FORM uses VINFO's variable, so it must be a closure.
403 (setq closure t)
404 ;; Make sure that the environment in which the variable is
405 ;; located is accessible (since we only ever pass the
406 ;; innermost environment to closures, if it's in some other
407 ;; envionment, there must be path to it from the innermost
408 ;; one).
409 (unless (byte-compile-lexvar-in-heap-p vinfo)
410 ;; To access the variable from FORM, it must be in the heap.
411 (error
412 "Compiler error: lexical variable `%s' should be heap-allocated but is not"
413 (car vinfo)))
414 (let ((closed-over-lexvar (assq (car vinfo) closed-over-lexenv)))
415 (byte-compile-heapenv-ensure-access
416 byte-compile-current-heap-environment
417 (byte-compile-lexvar-environment closed-over-lexvar))
418 ;; Put this variable in the new lexical environment
419 (push closed-over-lexvar lexenv))))
420 ;; Fill in the initial stack contents
421 (let ((stackpos 0))
422 (when closure
423 ;; Add the magic first argument that holds the environment pointer
424 (push (byte-compile-make-lexvar byte-compile-current-heap-environment
425 0)
426 lexenv)
427 (setq stackpos (1+ stackpos)))
428 ;; Add entries for each argument
429 (dolist (arg args)
430 (push (byte-compile-make-lexvar arg stackpos) lexenv)
431 (setq stackpos (1+ stackpos)))
432 ;; Return the new lexical environment
433 lexenv))))
434
435(defun byte-compile-closure-initial-lexenv-p (lexenv)
436 "Return non-nil if LEXENV is the initial lexical environment for a closure.
437This only works correctly when passed a new lexical environment as
438returned by `byte-compile-make-lambda-lexenv' (it works by checking to
439see whether there are any heap-allocated lexical variables in LEXENV)."
440 (let ((closure nil))
441 (while (and lexenv (not closure))
442 (when (byte-compile-lexvar-environment-p (pop lexenv))
443 (setq closure t)))
444 closure))
445
446
447;;; Heap environment vectors
448
449;; A `heap environment vector' is heap-allocated vector used to store
450;; variable that can't be put onto the stack.
451;;
452;; They are represented in the compiler by a list of the form
453;;
454;; (SIZE SIZE-CONST-ID INIT-POSITION . ENVS)
455;;
456;; SIZE is the current size of the vector (which may be
457;; incremented if another variable or environment-reference is added to
458;; the end). SIZE-CONST-ID is an `unknown constant id' (as returned by
459;; `byte-compile-push-unknown-constant') representing the constant used
460;; in the vector initialization code, and INIT-POSITION is a position
461;; in the byte-code output (as returned by `byte-compile-delay-out')
462;; at which more initialization code can be added.
463;; ENVS is a list of other environment vectors accessible form this one,
464;; where each element is of the form (ENV . OFFSET).
465
466;; constructor
467(defsubst byte-compile-make-heapenv (size-const-id init-position)
468 (list 0 size-const-id init-position))
469;; accessors
470(defsubst byte-compile-heapenv-size (heapenv) (car heapenv))
471(defsubst byte-compile-heapenv-size-const-id (heapenv) (cadr heapenv))
472(defsubst byte-compile-heapenv-init-position (heapenv) (nth 2 heapenv))
473(defsubst byte-compile-heapenv-accessible-envs (heapenv) (nthcdr 3 heapenv))
474
475(defun byte-compile-heapenv-add-slot (heapenv)
476 "Add a slot to the heap environment HEAPENV and return its offset."
477 (prog1 (car heapenv) (setcar heapenv (1+ (car heapenv)))))
478
479(defun byte-compile-heapenv-add-accessible-env (heapenv env offset)
480 "Add to HEAPENV's list of accessible environments, ENV at OFFSET."
481 (setcdr (nthcdr 2 heapenv)
482 (cons (cons env offset)
483 (byte-compile-heapenv-accessible-envs heapenv))))
484
485(defun byte-compile-push-heapenv ()
486 "Generate byte-code to push a new heap environment vector.
487Sets `byte-compile-current-heap-environment' to the compiler descriptor
488for the new heap environment.
489Return a `lexvar' descriptor for the new heap environment."
490 (let ((env-stack-pos byte-compile-depth)
491 size-const-id init-position)
492 ;; Generate code to push the vector
493 (byte-compile-push-constant 'make-vector)
494 (setq size-const-id (byte-compile-push-unknown-constant))
495 (byte-compile-push-constant nil)
496 (byte-compile-out 'byte-call 2)
497 (setq init-position (byte-compile-delay-out 3))
498 ;; Now make a heap-environment for the compiler to use
499 (setq byte-compile-current-heap-environment
500 (byte-compile-make-heapenv size-const-id init-position))
501 (byte-compile-make-lexvar byte-compile-current-heap-environment
502 env-stack-pos)))
503
504(defun byte-compile-heapenv-ensure-access (heapenv other-heapenv)
505 "Make sure that HEAPENV can be used to access OTHER-HEAPENV.
506If not, then add a new slot to HEAPENV pointing to OTHER-HEAPENV."
507 (unless (memq heapenv (byte-compile-heapenv-accessible-envs heapenv))
508 (let ((offset (byte-compile-heapenv-add-slot heapenv)))
509 (byte-compile-heapenv-add-accessible-env heapenv other-heapenv offset))))
510
511
512;;; Variable binding/unbinding
513
514(defun byte-compile-non-stack-bindings-p (clauses lforminfo)
515 "Return non-nil if any lexical bindings in CLAUSES are not stack-allocated.
516LFORMINFO should be information about lexical variables being bound."
517 (let ((vars (byte-compile-lforminfo-vars lforminfo)))
518 (or (not (= (length clauses) (length vars)))
519 (progn
520 (while (and vars clauses)
521 (when (byte-compile-lvarinfo-closed-over-p (pop vars))
522 (setq clauses nil)))
523 (not clauses)))))
524
525(defun byte-compile-let-clauses-trivial-init-p (clauses)
526 "Return true if let binding CLAUSES all have a `trivial' init value.
527Trivial means either a constant value, or a simple variable initialization."
528 (or (null clauses)
529 (and (or (atom (car clauses))
530 (atom (cadr (car clauses)))
531 (eq (car (cadr (car clauses))) 'quote))
532 (byte-compile-let-clauses-trivial-init-p (cdr clauses)))))
533
534(defun byte-compile-rearrange-let-clauses (clauses lforminfo)
535 "Return CLAUSES rearranged so non-stack variables come last if possible.
536Care is taken to only do so when it's clear that the meaning is the same.
537LFORMINFO should be information about lexical variables being bound."
538 ;; We currently do a very simple job by only exchanging clauses when
539 ;; one has a constant init, or one has a variable init and the other
540 ;; doesn't have a function call init (because that could change the
541 ;; value of the variable). This could be more clever and actually
542 ;; attempt to analyze which variables could possible be changed, etc.
543 (let ((unchanged nil)
544 (lex-non-stack nil)
545 (dynamic nil))
546 (while clauses
547 (let* ((clause (pop clauses))
548 (var (if (consp clause) (car clause) clause))
549 (init (and (consp clause) (cadr clause)))
550 (vinfo (assq var (byte-compile-lforminfo-vars lforminfo))))
551 (cond
552 ((or (and vinfo
553 (not (byte-compile-lvarinfo-closed-over-p vinfo)))
554 (not
555 (or (eq init nil) (eq init t)
556 (and (atom init) (not (symbolp init)))
557 (and (consp init) (eq (car init) 'quote))
558 (byte-compile-let-clauses-trivial-init-p clauses))))
559 (push clause unchanged))
560 (vinfo
561 (push clause lex-non-stack))
562 (t
563 (push clause dynamic)))))
564 (nconc (nreverse unchanged) (nreverse lex-non-stack) (nreverse dynamic))))
565
566(defun byte-compile-maybe-push-heap-environment (&optional lforminfo)
567 "Push a new heap environment if necessary.
568LFORMINFO should be information about lexical variables being bound.
569Return a lexical environment containing only the heap vector (or
570nil if nothing was pushed).
571Also, `byte-compile-current-heap-environment' and
572`byte-compile-current-num-closures' are updated to reflect any change (so they
573should probably be bound by the caller to ensure that the new values have the
574proper scope)."
575 ;; We decide whether a new heap environment is required by seeing if
576 ;; the number of closures inside the form described by LFORMINFO is
577 ;; the same as the number inside the binding form that created the
578 ;; currently active heap environment.
579 (let ((nclosures
580 (and lforminfo (byte-compile-lforminfo-num-closures lforminfo))))
581 (if (or (null lforminfo)
582 (= nclosures byte-compile-current-num-closures))
583 ;; No need to push a heap environment.
584 nil
585 ;; Have to push one. A heap environment is really just a vector, so
586 ;; we emit bytecodes to create a vector. However, the size is not
587 ;; fixed yet (the vector can grow if subforms use it to store
588 ;; values, and if `access points' to parent heap environments are
589 ;; added), so we use `byte-compile-push-unknown-constant' to push the
590 ;; vector size.
591 (setq byte-compile-current-num-closures nclosures)
592 (list (byte-compile-push-heapenv)))))
593
594(defun byte-compile-bind (var init-lexenv &optional lforminfo)
595 "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'.
596INIT-LEXENV should be a lexical-environment alist describing the
597positions of the init value that have been pushed on the stack, and
598LFORMINFO should be information about lexical variables being bound.
599Return non-nil if the TOS value was popped."
600 ;; The presence of lexical bindings mean that we may have to
601 ;; juggle things on the stack, either to move them to TOS for
602 ;; dynamic binding, or to put them in a non-stack environment
603 ;; vector.
604 (let ((vinfo (assq var (byte-compile-lforminfo-vars lforminfo))))
605 (cond ((and (null vinfo) (eq var (caar init-lexenv)))
606 ;; VAR is dynamic and is on the top of the
607 ;; stack, so we can just bind it like usual
608 (byte-compile-dynamic-variable-bind var)
609 t)
610 ((null vinfo)
611 ;; VAR is dynamic, but we have to get its
612 ;; value out of the middle of the stack
613 (let ((stack-pos (cdr (assq var init-lexenv))))
614 (byte-compile-stack-ref stack-pos)
615 (byte-compile-dynamic-variable-bind var)
616 ;; Now we have to store nil into its temporary
617 ;; stack position to avoid problems with GC
618 (byte-compile-push-constant nil)
619 (byte-compile-stack-set stack-pos))
620 nil)
621 ((byte-compile-lvarinfo-closed-over-p vinfo)
622 ;; VAR is lexical, but needs to be in a
623 ;; heap-allocated environment.
624 (unless byte-compile-current-heap-environment
625 (error "No current heap-environment to allocate `%s' in!" var))
626 (let ((init-stack-pos
627 ;; nil if the init value is on the top of the stack,
628 ;; otherwise the position of the init value on the stack.
629 (and (not (eq var (caar init-lexenv)))
630 (byte-compile-lexvar-offset (assq var init-lexenv))))
631 (env-vec-pos
632 ;; Position of VAR in the environment vector
633 (byte-compile-lexvar-offset
634 (assq var byte-compile-lexical-environment)))
635 (env-vec-stack-pos
636 ;; Position of the the environment vector on the stack
637 ;; (the heap-environment must _always_ be available on
638 ;; the stack!)
639 (byte-compile-lexvar-offset
640 (assq byte-compile-current-heap-environment
641 byte-compile-lexical-environment))))
642 (unless env-vec-stack-pos
643 (error "Couldn't find location of current heap environment!"))
644 (when init-stack-pos
645 ;; VAR is not on the top of the stack, so get it
646 (byte-compile-stack-ref init-stack-pos))
647 (byte-compile-stack-ref env-vec-stack-pos)
648 ;; Store the variable into the vector
649 (byte-compile-out 'byte-vec-set env-vec-pos)
650 (when init-stack-pos
651 ;; Store nil into VAR's temporary stack
652 ;; position to avoid problems with GC
653 (byte-compile-push-constant nil)
654 (byte-compile-stack-set init-stack-pos))
655 ;; Push a record of VAR's new lexical binding
656 (push (byte-compile-make-lexvar
657 var env-vec-pos byte-compile-current-heap-environment)
658 byte-compile-lexical-environment)
659 (not init-stack-pos)))
660 (t
661 ;; VAR is a simple stack-allocated lexical variable
662 (push (assq var init-lexenv)
663 byte-compile-lexical-environment)
664 nil))))
665
666(defun byte-compile-unbind (clauses init-lexenv
667 &optional lforminfo preserve-body-value)
668 "Emit byte-codes to unbind the variables bound by CLAUSES.
669CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a
670lexical-environment alist describing the positions of the init value that
671have been pushed on the stack, and LFORMINFO should be information about
672the lexical variables that were bound. If PRESERVE-BODY-VALUE is true,
673then an additional value on the top of the stack, above any lexical binding
674slots, is preserved, so it will be on the top of the stack after all
675binding slots have been popped."
676 ;; Unbind dynamic variables
677 (let ((num-dynamic-bindings 0))
678 (if lforminfo
679 (dolist (clause clauses)
680 (unless (assq (if (consp clause) (car clause) clause)
681 (byte-compile-lforminfo-vars lforminfo))
682 (setq num-dynamic-bindings (1+ num-dynamic-bindings))))
683 (setq num-dynamic-bindings (length clauses)))
684 (unless (zerop num-dynamic-bindings)
685 (byte-compile-out 'byte-unbind num-dynamic-bindings)))
686 ;; Pop lexical variables off the stack, possibly preserving the
687 ;; return value of the body.
688 (when init-lexenv
689 ;; INIT-LEXENV contains all init values left on the stack
690 (byte-compile-discard (length init-lexenv) preserve-body-value)))
691
692
693(provide 'byte-lexbind)
694
695;;; arch-tag: b8f1dff6-9edb-4430-a96f-323d42a681a9
696;;; byte-lexbind.el ends here
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index e461010a6ce..4c0094dd78b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -186,8 +186,8 @@
186(eval-when-compile (require 'cl)) 186(eval-when-compile (require 'cl))
187 187
188(defun byte-compile-log-lap-1 (format &rest args) 188(defun byte-compile-log-lap-1 (format &rest args)
189 (if (aref byte-code-vector 0) 189;; (if (aref byte-code-vector 0)
190 (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) 190;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
191 (byte-compile-log-1 191 (byte-compile-log-1
192 (apply 'format format 192 (apply 'format format
193 (let (c a) 193 (let (c a)
@@ -281,7 +281,8 @@
281 (byte-code ,string ,(aref fn 2) ,(aref fn 3))) 281 (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
282 (cdr form))) 282 (cdr form)))
283 (if (eq (car-safe fn) 'lambda) 283 (if (eq (car-safe fn) 'lambda)
284 (cons fn (cdr form)) 284 (macroexpand-all (cons fn (cdr form))
285 byte-compile-macro-environment)
285 ;; Give up on inlining. 286 ;; Give up on inlining.
286 form)))))) 287 form))))))
287 288
@@ -1332,14 +1333,15 @@
1332 ((>= op byte-constant) 1333 ((>= op byte-constant)
1333 (prog1 (- op byte-constant) ;offset in opcode 1334 (prog1 (- op byte-constant) ;offset in opcode
1334 (setq op byte-constant))) 1335 (setq op byte-constant)))
1335 ((and (>= op byte-constant2) 1336 ((or (and (>= op byte-constant2)
1336 (<= op byte-goto-if-not-nil-else-pop)) 1337 (<= op byte-goto-if-not-nil-else-pop))
1338 (= op byte-stack-set2))
1337 (setq ptr (1+ ptr)) ;offset in next 2 bytes 1339 (setq ptr (1+ ptr)) ;offset in next 2 bytes
1338 (+ (aref bytes ptr) 1340 (+ (aref bytes ptr)
1339 (progn (setq ptr (1+ ptr)) 1341 (progn (setq ptr (1+ ptr))
1340 (lsh (aref bytes ptr) 8)))) 1342 (lsh (aref bytes ptr) 8))))
1341 ((and (>= op byte-listN) 1343 ((and (>= op byte-listN)
1342 (<= op byte-insertN)) 1344 (<= op byte-discardN))
1343 (setq ptr (1+ ptr)) ;offset in next byte 1345 (setq ptr (1+ ptr)) ;offset in next byte
1344 (aref bytes ptr)))) 1346 (aref bytes ptr))))
1345 1347
@@ -1400,7 +1402,16 @@
1400 (if (= ptr (1- length)) 1402 (if (= ptr (1- length))
1401 (setq op nil) 1403 (setq op nil)
1402 (setq offset (or endtag (setq endtag (byte-compile-make-tag))) 1404 (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
1403 op 'byte-goto)))) 1405 op 'byte-goto)))
1406 ((eq op 'byte-stack-set2)
1407 (setq op 'byte-stack-set))
1408 ((and (eq op 'byte-discardN) (>= offset #x80))
1409 ;; The top bit of the operand for byte-discardN is a flag,
1410 ;; saying whether the top-of-stack is preserved. In
1411 ;; lapcode, we represent this by using a different opcode
1412 ;; (with the flag removed from the operand).
1413 (setq op 'byte-discardN-preserve-tos)
1414 (setq offset (- offset #x80))))
1404 ;; lap = ( [ (pc . (op . arg)) ]* ) 1415 ;; lap = ( [ (pc . (op . arg)) ]* )
1405 (setq lap (cons (cons optr (cons op (or offset 0))) 1416 (setq lap (cons (cons optr (cons op (or offset 0)))
1406 lap)) 1417 lap))
@@ -1456,7 +1467,7 @@
1456 byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max 1467 byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
1457 byte-point-min byte-following-char byte-preceding-char 1468 byte-point-min byte-following-char byte-preceding-char
1458 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp 1469 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
1459 byte-current-buffer byte-interactive-p)) 1470 byte-current-buffer byte-interactive-p byte-stack-ref))
1460 1471
1461(defconst byte-compile-side-effect-free-ops 1472(defconst byte-compile-side-effect-free-ops
1462 (nconc 1473 (nconc
@@ -1465,7 +1476,7 @@
1465 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate 1476 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
1466 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax 1477 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
1467 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt 1478 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
1468 byte-member byte-assq byte-quo byte-rem) 1479 byte-member byte-assq byte-quo byte-rem byte-vec-ref)
1469 byte-compile-side-effect-and-error-free-ops)) 1480 byte-compile-side-effect-and-error-free-ops))
1470 1481
1471;; This crock is because of the way DEFVAR_BOOL variables work. 1482;; This crock is because of the way DEFVAR_BOOL variables work.
@@ -1498,12 +1509,50 @@
1498;; The variable `byte-boolean-vars' is now primitive and updated 1509;; The variable `byte-boolean-vars' is now primitive and updated
1499;; automatically by DEFVAR_BOOL. 1510;; automatically by DEFVAR_BOOL.
1500 1511
1512(defmacro byte-opt-update-stack-params (stack-adjust stack-depth lap0 rest lap)
1513 "...macro used by byte-optimize-lapcode..."
1514 `(progn
1515 (byte-compile-log-lap "Before %s [depth = %s]" ,lap0 ,stack-depth)
1516 (cond ((eq (car ,lap0) 'TAG)
1517 ;; A tag can encode the expected stack depth.
1518 (when (cddr ,lap0)
1519 ;; First, check to see if our notion of the current stack
1520 ;; depth agrees with this tag. We don't check at the
1521 ;; beginning of the function, because the presence of
1522 ;; lexical arguments means the first tag will have a
1523 ;; non-zero offset.
1524 (when (and (not (eq ,rest ,lap)) ; not at first insn
1525 ,stack-depth ; not just after a goto
1526 (not (= (cddr ,lap0) ,stack-depth)))
1527 (error "Compiler error: optimizer is confused about %s:
1528 %s != %s at lapcode %s" ',stack-depth (cddr ,lap0) ,stack-depth ,lap0))
1529 ;; Now set out current depth from this tag
1530 (setq ,stack-depth (cddr ,lap0)))
1531 (setq ,stack-adjust 0))
1532 ((memq (car ,lap0) '(byte-goto byte-return))
1533 ;; These insns leave us in an unknown state
1534 (setq ,stack-adjust nil))
1535 ((car ,lap0)
1536 ;; Not a no-op, set ,stack-adjust for lap0. ,stack-adjust will
1537 ;; be added to ,stack-depth at the end of the loop, so any code
1538 ;; that modifies the instruction sequence must adjust this too.
1539 (setq ,stack-adjust
1540 (byte-compile-stack-adjustment (car ,lap0) (cdr ,lap0)))))
1541 (byte-compile-log-lap "Before %s [depth => %s, adj = %s]" ,lap0 ,stack-depth ,stack-adjust)
1542 ))
1543
1501(defun byte-optimize-lapcode (lap &optional for-effect) 1544(defun byte-optimize-lapcode (lap &optional for-effect)
1502 "Simple peephole optimizer. LAP is both modified and returned. 1545 "Simple peephole optimizer. LAP is both modified and returned.
1503If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." 1546If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1504 (let (lap0 1547 (let (lap0
1505 lap1 1548 lap1
1506 lap2 1549 lap2
1550 stack-adjust
1551 stack-depth
1552 (initial-stack-depth
1553 (if (and lap (eq (car (car lap)) 'TAG))
1554 (cdr (cdr (car lap)))
1555 0))
1507 (keep-going 'first-time) 1556 (keep-going 'first-time)
1508 (add-depth 0) 1557 (add-depth 0)
1509 rest tmp tmp2 tmp3 1558 rest tmp tmp2 tmp3
@@ -1514,12 +1563,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1514 (or (eq keep-going 'first-time) 1563 (or (eq keep-going 'first-time)
1515 (byte-compile-log-lap " ---- next pass")) 1564 (byte-compile-log-lap " ---- next pass"))
1516 (setq rest lap 1565 (setq rest lap
1566 stack-depth initial-stack-depth
1517 keep-going nil) 1567 keep-going nil)
1518 (while rest 1568 (while rest
1519 (setq lap0 (car rest) 1569 (setq lap0 (car rest)
1520 lap1 (nth 1 rest) 1570 lap1 (nth 1 rest)
1521 lap2 (nth 2 rest)) 1571 lap2 (nth 2 rest))
1522 1572
1573 (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap)
1574
1523 ;; You may notice that sequences like "dup varset discard" are 1575 ;; You may notice that sequences like "dup varset discard" are
1524 ;; optimized but sequences like "dup varset TAG1: discard" are not. 1576 ;; optimized but sequences like "dup varset TAG1: discard" are not.
1525 ;; You may be tempted to change this; resist that temptation. 1577 ;; You may be tempted to change this; resist that temptation.
@@ -1533,22 +1585,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1533 ((and (eq 'byte-discard (car lap1)) 1585 ((and (eq 'byte-discard (car lap1))
1534 (memq (car lap0) side-effect-free)) 1586 (memq (car lap0) side-effect-free))
1535 (setq keep-going t) 1587 (setq keep-going t)
1536 (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
1537 (setq rest (cdr rest)) 1588 (setq rest (cdr rest))
1538 (cond ((= tmp 1) 1589 (cond ((= stack-adjust 1)
1539 (byte-compile-log-lap 1590 (byte-compile-log-lap
1540 " %s discard\t-->\t<deleted>" lap0) 1591 " %s discard\t-->\t<deleted>" lap0)
1541 (setq lap (delq lap0 (delq lap1 lap)))) 1592 (setq lap (delq lap0 (delq lap1 lap))))
1542 ((= tmp 0) 1593 ((= stack-adjust 0)
1543 (byte-compile-log-lap 1594 (byte-compile-log-lap
1544 " %s discard\t-->\t<deleted> discard" lap0) 1595 " %s discard\t-->\t<deleted> discard" lap0)
1545 (setq lap (delq lap0 lap))) 1596 (setq lap (delq lap0 lap)))
1546 ((= tmp -1) 1597 ((= stack-adjust -1)
1547 (byte-compile-log-lap 1598 (byte-compile-log-lap
1548 " %s discard\t-->\tdiscard discard" lap0) 1599 " %s discard\t-->\tdiscard discard" lap0)
1549 (setcar lap0 'byte-discard) 1600 (setcar lap0 'byte-discard)
1550 (setcdr lap0 0)) 1601 (setcdr lap0 0))
1551 ((error "Optimizer error: too much on the stack")))) 1602 ((error "Optimizer error: too much on the stack")))
1603 (setq stack-adjust (1- stack-adjust)))
1552 ;; 1604 ;;
1553 ;; goto*-X X: --> X: 1605 ;; goto*-X X: --> X:
1554 ;; 1606 ;;
@@ -1573,10 +1625,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1573 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup 1625 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1574 ;; The latter two can enable other optimizations. 1626 ;; The latter two can enable other optimizations.
1575 ;; 1627 ;;
1576 ((and (eq 'byte-varref (car lap2)) 1628 ((or (and (eq 'byte-varref (car lap2))
1577 (eq (cdr lap1) (cdr lap2)) 1629 (eq (cdr lap1) (cdr lap2))
1578 (memq (car lap1) '(byte-varset byte-varbind))) 1630 (memq (car lap1) '(byte-varset byte-varbind)))
1579 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) 1631 (and (eq (car lap2) 'byte-stack-ref)
1632 (eq (car lap1) 'byte-stack-set)
1633 (eq (cdr lap1) (cdr lap2))))
1634 (if (and (eq 'byte-varref (car lap2))
1635 (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1580 (not (eq (car lap0) 'byte-constant))) 1636 (not (eq (car lap0) 'byte-constant)))
1581 nil 1637 nil
1582 (setq keep-going t) 1638 (setq keep-going t)
@@ -1608,10 +1664,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1608 ;; 1664 ;;
1609 ((and (eq 'byte-dup (car lap0)) 1665 ((and (eq 'byte-dup (car lap0))
1610 (eq 'byte-discard (car lap2)) 1666 (eq 'byte-discard (car lap2))
1611 (memq (car lap1) '(byte-varset byte-varbind))) 1667 (memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set)))
1612 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) 1668 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1613 (setq keep-going t 1669 (setq keep-going t
1614 rest (cdr rest)) 1670 rest (cdr rest)
1671 stack-adjust -1)
1615 (setq lap (delq lap0 (delq lap2 lap)))) 1672 (setq lap (delq lap0 (delq lap2 lap))))
1616 ;; 1673 ;;
1617 ;; not goto-X-if-nil --> goto-X-if-non-nil 1674 ;; not goto-X-if-nil --> goto-X-if-non-nil
@@ -1633,7 +1690,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1633 'byte-goto-if-not-nil 1690 'byte-goto-if-not-nil
1634 'byte-goto-if-nil)) 1691 'byte-goto-if-nil))
1635 (setq lap (delq lap0 lap)) 1692 (setq lap (delq lap0 lap))
1636 (setq keep-going t)) 1693 (setq keep-going t
1694 stack-adjust 0))
1637 ;; 1695 ;;
1638 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: 1696 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1639 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: 1697 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
@@ -1649,7 +1707,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1649 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" 1707 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1650 lap0 lap1 lap2 1708 lap0 lap1 lap2
1651 (cons inverse (cdr lap1)) lap2) 1709 (cons inverse (cdr lap1)) lap2)
1652 (setq lap (delq lap0 lap)) 1710 (setq lap (delq lap0 lap)
1711 stack-adjust 0)
1653 (setcar lap1 inverse) 1712 (setcar lap1 inverse)
1654 (setq keep-going t))) 1713 (setq keep-going t)))
1655 ;; 1714 ;;
@@ -1666,15 +1725,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1666 (setq rest (cdr rest) 1725 (setq rest (cdr rest)
1667 lap (delq lap0 (delq lap1 lap)))) 1726 lap (delq lap0 (delq lap1 lap))))
1668 (t 1727 (t
1669 (if (memq (car lap1) byte-goto-always-pop-ops) 1728 (byte-compile-log-lap " %s %s\t-->\t%s"
1670 (progn 1729 lap0 lap1
1671 (byte-compile-log-lap " %s %s\t-->\t%s" 1730 (cons 'byte-goto (cdr lap1)))
1672 lap0 lap1 (cons 'byte-goto (cdr lap1))) 1731 (when (memq (car lap1) byte-goto-always-pop-ops)
1673 (setq lap (delq lap0 lap))) 1732 (setq lap (delq lap0 lap)))
1674 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
1675 (cons 'byte-goto (cdr lap1))))
1676 (setcar lap1 'byte-goto))) 1733 (setcar lap1 'byte-goto)))
1677 (setq keep-going t)) 1734 (setq keep-going t
1735 stack-adjust 0))
1678 ;; 1736 ;;
1679 ;; varref-X varref-X --> varref-X dup 1737 ;; varref-X varref-X --> varref-X dup
1680 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup 1738 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
@@ -1682,14 +1740,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1682 ;; because that would inhibit some goto optimizations; we 1740 ;; because that would inhibit some goto optimizations; we
1683 ;; optimize the const-X case after all other optimizations. 1741 ;; optimize the const-X case after all other optimizations.
1684 ;; 1742 ;;
1685 ((and (eq 'byte-varref (car lap0)) 1743 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1686 (progn 1744 (progn
1687 (setq tmp (cdr rest)) 1745 (setq tmp (cdr rest) tmp2 0)
1688 (while (eq (car (car tmp)) 'byte-dup) 1746 (while (eq (car (car tmp)) 'byte-dup)
1689 (setq tmp (cdr tmp))) 1747 (setq tmp (cdr tmp) tmp2 (1+ tmp2)))
1690 t) 1748 t)
1691 (eq (cdr lap0) (cdr (car tmp))) 1749 (eq (car lap0) (car (car tmp)))
1692 (eq 'byte-varref (car (car tmp)))) 1750 (eq (cdr lap0) (cdr (car tmp))))
1693 (if (memq byte-optimize-log '(t byte)) 1751 (if (memq byte-optimize-log '(t byte))
1694 (let ((str "")) 1752 (let ((str ""))
1695 (setq tmp2 (cdr rest)) 1753 (setq tmp2 (cdr rest))
@@ -1701,7 +1759,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1701 (setq keep-going t) 1759 (setq keep-going t)
1702 (setcar (car tmp) 'byte-dup) 1760 (setcar (car tmp) 'byte-dup)
1703 (setcdr (car tmp) 0) 1761 (setcdr (car tmp) 0)
1704 (setq rest tmp)) 1762 (setq rest tmp
1763 stack-adjust (+ 2 tmp2)))
1705 ;; 1764 ;;
1706 ;; TAG1: TAG2: --> TAG1: <deleted> 1765 ;; TAG1: TAG2: --> TAG1: <deleted>
1707 ;; (and other references to TAG2 are replaced with TAG1) 1766 ;; (and other references to TAG2 are replaced with TAG1)
@@ -1768,7 +1827,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1768 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) 1827 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1769 (setcar rest lap1) 1828 (setcar rest lap1)
1770 (setcar (cdr rest) lap0) 1829 (setcar (cdr rest) lap0)
1771 (setq keep-going t)) 1830 (setq keep-going t
1831 stack-adjust 0))
1772 ;; 1832 ;;
1773 ;; varbind-X unbind-N --> discard unbind-(N-1) 1833 ;; varbind-X unbind-N --> discard unbind-(N-1)
1774 ;; save-excursion unbind-N --> unbind-(N-1) 1834 ;; save-excursion unbind-N --> unbind-(N-1)
@@ -1794,6 +1854,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1794 "")) 1854 ""))
1795 (setq keep-going t)) 1855 (setq keep-going t))
1796 ;; 1856 ;;
1857 ;; stack-ref-N --> dup ; where N is TOS
1858 ;;
1859 ((and (eq (car lap0) 'byte-stack-ref)
1860 (= (cdr lap0) (1- stack-depth)))
1861 (setcar lap0 'byte-dup)
1862 (setcdr lap0 nil)
1863 (setq keep-going t))
1864 ;;
1797 ;; goto*-X ... X: goto-Y --> goto*-Y 1865 ;; goto*-X ... X: goto-Y --> goto*-Y
1798 ;; goto-X ... X: return --> return 1866 ;; goto-X ... X: return --> return
1799 ;; 1867 ;;
@@ -1870,20 +1938,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1870 (cdr tmp)))) 1938 (cdr tmp))))
1871 (setcdr lap1 (car (cdr tmp))) 1939 (setcdr lap1 (car (cdr tmp)))
1872 (setq lap (delq lap0 lap)))) 1940 (setq lap (delq lap0 lap))))
1873 (setq keep-going t)) 1941 (setq keep-going t
1942 stack-adjust 0))
1874 ;; 1943 ;;
1875 ;; X: varref-Y ... varset-Y goto-X --> 1944 ;; X: varref-Y ... varset-Y goto-X -->
1876 ;; X: varref-Y Z: ... dup varset-Y goto-Z 1945 ;; X: varref-Y Z: ... dup varset-Y goto-Z
1877 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) 1946 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1878 ;; (This is so usual for while loops that it is worth handling). 1947 ;; (This is so usual for while loops that it is worth handling).
1879 ;; 1948 ;;
1880 ((and (eq (car lap1) 'byte-varset) 1949 ((and (memq (car lap1) '(byte-varset byte-stack-set))
1881 (eq (car lap2) 'byte-goto) 1950 (eq (car lap2) 'byte-goto)
1882 (not (memq (cdr lap2) rest)) ;Backwards jump 1951 (not (memq (cdr lap2) rest)) ;Backwards jump
1883 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) 1952 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
1884 'byte-varref) 1953 (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref))
1885 (eq (cdr (car tmp)) (cdr lap1)) 1954 (eq (cdr (car tmp)) (cdr lap1))
1886 (not (memq (car (cdr lap1)) byte-boolean-vars))) 1955 (not (and (eq (car lap1) 'byte-varref)
1956 (memq (car (cdr lap1)) byte-boolean-vars))))
1887 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) 1957 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
1888 (let ((newtag (byte-compile-make-tag))) 1958 (let ((newtag (byte-compile-make-tag)))
1889 (byte-compile-log-lap 1959 (byte-compile-log-lap
@@ -1940,10 +2010,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1940 byte-goto-if-not-nil 2010 byte-goto-if-not-nil
1941 byte-goto byte-goto)))) 2011 byte-goto byte-goto))))
1942 ) 2012 )
1943 (setq keep-going t)) 2013 (setq keep-going t
2014 stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1)))
1944 ) 2015 )
2016
2017 (setq stack-depth
2018 (and stack-depth stack-adjust (+ stack-depth stack-adjust)))
1945 (setq rest (cdr rest))) 2019 (setq rest (cdr rest)))
1946 ) 2020 )
2021
1947 ;; Cleanup stage: 2022 ;; Cleanup stage:
1948 ;; Rebuild byte-compile-constants / byte-compile-variables. 2023 ;; Rebuild byte-compile-constants / byte-compile-variables.
1949 ;; Simple optimizations that would inhibit other optimizations if they 2024 ;; Simple optimizations that would inhibit other optimizations if they
@@ -1951,10 +2026,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1951 ;; need to do more than once. 2026 ;; need to do more than once.
1952 (setq byte-compile-constants nil 2027 (setq byte-compile-constants nil
1953 byte-compile-variables nil) 2028 byte-compile-variables nil)
1954 (setq rest lap) 2029 (setq rest lap
2030 stack-depth initial-stack-depth)
2031 (byte-compile-log-lap " ---- final pass")
1955 (while rest 2032 (while rest
1956 (setq lap0 (car rest) 2033 (setq lap0 (car rest)
1957 lap1 (nth 1 rest)) 2034 lap1 (nth 1 rest))
2035 (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap)
1958 (if (memq (car lap0) byte-constref-ops) 2036 (if (memq (car lap0) byte-constref-ops)
1959 (if (or (eq (car lap0) 'byte-constant) 2037 (if (or (eq (car lap0) 'byte-constant)
1960 (eq (car lap0) 'byte-constant2)) 2038 (eq (car lap0) 'byte-constant2))
@@ -2001,11 +2079,108 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
2001 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 2079 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
2002 (cons 'byte-unbind 2080 (cons 'byte-unbind
2003 (+ (cdr lap0) (cdr lap1)))) 2081 (+ (cdr lap0) (cdr lap1))))
2004 (setq keep-going t)
2005 (setq lap (delq lap0 lap)) 2082 (setq lap (delq lap0 lap))
2006 (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) 2083 (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
2084
2085 ;;
2086 ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
2087 ;; stack-set-M [discard/discardN ...] --> discardN
2088 ;;
2089 ((and (eq (car lap0) 'byte-stack-set)
2090 (memq (car lap1) '(byte-discard byte-discardN))
2091 (progn
2092 ;; See if enough discard operations follow to expose or
2093 ;; destroy the value stored by the stack-set.
2094 (setq tmp (cdr rest))
2095 (setq tmp2 (- stack-depth 2 (cdr lap0)))
2096 (setq tmp3 0)
2097 (while (memq (car (car tmp)) '(byte-discard byte-discardN))
2098 (if (eq (car (car tmp)) 'byte-discard)
2099 (setq tmp3 (1+ tmp3))
2100 (setq tmp3 (+ tmp3 (cdr (car tmp)))))
2101 (setq tmp (cdr tmp)))
2102 (>= tmp3 tmp2)))
2103 ;; Do the optimization
2104 (setq lap (delq lap0 lap))
2105 (cond ((= tmp2 tmp3)
2106 ;; The value stored is the new TOS, so pop one more value
2107 ;; (to get rid of the old value) using the TOS-preserving
2108 ;; discard operator.
2109 (setcar lap1 'byte-discardN-preserve-tos)
2110 (setcdr lap1 (1+ tmp3)))
2111 (t
2112 ;; Otherwise, the value stored is lost, so just use a
2113 ;; normal discard.
2114 (setcar lap1 'byte-discardN)
2115 (setcdr lap1 tmp3)))
2116 (setcdr (cdr rest) tmp)
2117 (setq stack-adjust 0)
2118 (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
2119 lap0 lap1))
2120
2121 ;;
2122 ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
2123 ;; discardN-(X+Y)
2124 ;;
2125 ((and (memq (car lap0)
2126 '(byte-discard
2127 byte-discardN
2128 byte-discardN-preserve-tos))
2129 (memq (car lap1) '(byte-discard byte-discardN)))
2130 (setq lap (delq lap0 lap))
2131 (byte-compile-log-lap
2132 " %s %s\t-->\t(discardN %s)"
2133 lap0 lap1
2134 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2135 (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2136 (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2137 (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2138 (setcar lap1 'byte-discardN)
2139 (setq stack-adjust 0))
2140
2141 ;;
2142 ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
2143 ;; discardN-preserve-tos-(X+Y)
2144 ;;
2145 ((and (eq (car lap0) 'byte-discardN-preserve-tos)
2146 (eq (car lap1) 'byte-discardN-preserve-tos))
2147 (setq lap (delq lap0 lap))
2148 (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
2149 (setq stack-adjust 0)
2150 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
2151
2152 ;;
2153 ;; discardN-preserve-tos return --> return
2154 ;; dup return --> return
2155 ;; stack-set-N return --> return ; where N is TOS-1
2156 ;;
2157 ((and (eq (car lap1) 'byte-return)
2158 (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
2159 (and (eq (car lap0) 'byte-stack-set)
2160 (= (cdr lap0) (- stack-depth 2)))))
2161 ;; the byte-code interpreter will pop the stack for us, so
2162 ;; we can just leave stuff on it
2163 (setq lap (delq lap0 lap))
2164 (setq stack-adjust 0)
2165 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
2166
2167 ;;
2168 ;; dup stack-set-N return --> return ; where N is TOS
2169 ;;
2170 ((and (eq (car lap0) 'byte-dup)
2171 (eq (car lap1) 'byte-stack-set)
2172 (eq (car (car (cdr (cdr rest)))) 'byte-return)
2173 (= (cdr lap1) (1- stack-depth)))
2174 (setq lap (delq lap0 (delq lap1 lap)))
2175 (setq rest (cdr rest))
2176 (setq stack-adjust 0)
2177 (byte-compile-log-lap " dup %s return\t-->\treturn" lap1))
2007 ) 2178 )
2179
2180 (setq stack-depth
2181 (and stack-depth stack-adjust (+ stack-depth stack-adjust)))
2008 (setq rest (cdr rest))) 2182 (setq rest (cdr rest)))
2183
2009 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) 2184 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
2010 lap) 2185 lap)
2011 2186
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 217afea9f8a..c80bcd49b82 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -116,12 +116,55 @@
116;; Some versions of `file' can be customized to recognize that. 116;; Some versions of `file' can be customized to recognize that.
117 117
118(require 'backquote) 118(require 'backquote)
119(require 'macroexp)
119(eval-when-compile (require 'cl)) 120(eval-when-compile (require 'cl))
120 121
121(or (fboundp 'defsubst) 122(or (fboundp 'defsubst)
122 ;; This really ought to be loaded already! 123 ;; This really ought to be loaded already!
123 (load "byte-run")) 124 (load "byte-run"))
124 125
126;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation
127;; errors; however that file also wants to do (require 'bytecomp) for the
128;; same reason. Since we know it's OK to load byte-lexbind.el second, we
129;; have that file require a feature that's provided before at the beginning
130;; of this file, to avoid an infinite require loop.
131;; `eval-when-compile' is defined in byte-run.el, so it must come after the
132;; preceding load expression.
133(provide 'bytecomp-preload)
134(eval-when-compile (require 'byte-lexbind))
135
136;; The feature of compiling in a specific target Emacs version
137;; has been turned off because compile time options are a bad idea.
138(defmacro byte-compile-single-version () nil)
139(defmacro byte-compile-version-cond (cond) cond)
140
141;; The crud you see scattered through this file of the form
142;; (or (and (boundp 'epoch::version) epoch::version)
143;; (string-lessp emacs-version "19"))
144;; is because the Epoch folks couldn't be bothered to follow the
145;; normal emacs version numbering convention.
146
147;; (if (byte-compile-version-cond
148;; (or (and (boundp 'epoch::version) epoch::version)
149;; (string-lessp emacs-version "19")))
150;; (progn
151;; ;; emacs-18 compatibility.
152;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined
153;;
154;; (if (byte-compile-single-version)
155;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil)
156;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil))
157;;
158;; (or (and (fboundp 'member)
159;; ;; avoid using someone else's possibly bogus definition of this.
160;; (subrp (symbol-function 'member)))
161;; (defun member (elt list)
162;; "like memq, but uses equal instead of eq. In v19, this is a subr."
163;; (while (and list (not (equal elt (car list))))
164;; (setq list (cdr list)))
165;; list))))
166
167
125(defgroup bytecomp nil 168(defgroup bytecomp nil
126 "Emacs Lisp byte-compiler." 169 "Emacs Lisp byte-compiler."
127 :group 'lisp) 170 :group 'lisp)
@@ -398,7 +441,17 @@ specify different fields to sort on."
398 :type '(choice (const name) (const callers) (const calls) 441 :type '(choice (const name) (const callers) (const calls)
399 (const calls+callers) (const nil))) 442 (const calls+callers) (const nil)))
400 443
401(defvar byte-compile-debug nil) 444;(defvar byte-compile-debug nil)
445(defvar byte-compile-debug t)
446
447;; (defvar byte-compile-overwrite-file t
448;; "If nil, old .elc files are deleted before the new is saved, and .elc
449;; files will have the same modes as the corresponding .el file. Otherwise,
450;; existing .elc files will simply be overwritten, and the existing modes
451;; will not be changed. If this variable is nil, then an .elc file which
452;; is a symbolic link will be turned into a normal file, instead of the file
453;; which the link points to being overwritten.")
454
402(defvar byte-compile-constants nil 455(defvar byte-compile-constants nil
403 "List of all constants encountered during compilation of this form.") 456 "List of all constants encountered during compilation of this form.")
404(defvar byte-compile-variables nil 457(defvar byte-compile-variables nil
@@ -418,11 +471,18 @@ This list lives partly on the stack.")
418;; (byte-compiler-options . (lambda (&rest forms) 471;; (byte-compiler-options . (lambda (&rest forms)
419;; (apply 'byte-compiler-options-handler forms))) 472;; (apply 'byte-compiler-options-handler forms)))
420 (eval-when-compile . (lambda (&rest body) 473 (eval-when-compile . (lambda (&rest body)
421 (list 'quote 474 (list
422 (byte-compile-eval (byte-compile-top-level 475 'quote
423 (cons 'progn body)))))) 476 (byte-compile-eval
477 (byte-compile-top-level
478 (macroexpand-all
479 (cons 'progn body)
480 byte-compile-initial-macro-environment))))))
424 (eval-and-compile . (lambda (&rest body) 481 (eval-and-compile . (lambda (&rest body)
425 (byte-compile-eval-before-compile (cons 'progn body)) 482 (byte-compile-eval-before-compile
483 (macroexpand-all
484 (cons 'progn body)
485 byte-compile-initial-macro-environment))
426 (cons 'progn body)))) 486 (cons 'progn body))))
427 "The default macro-environment passed to macroexpand by the compiler. 487 "The default macro-environment passed to macroexpand by the compiler.
428Placing a macro here will cause a macro to have different semantics when 488Placing a macro here will cause a macro to have different semantics when
@@ -453,6 +513,14 @@ defined with incorrect args.")
453Used for warnings about calling a function that is defined during compilation 513Used for warnings about calling a function that is defined during compilation
454but won't necessarily be defined when the compiled file is loaded.") 514but won't necessarily be defined when the compiled file is loaded.")
455 515
516;; Variables for lexical binding
517(defvar byte-compile-lexical-environment nil
518 "The current lexical environment.")
519(defvar byte-compile-current-heap-environment nil
520 "If non-nil, a descriptor for the current heap-allocated lexical environment.")
521(defvar byte-compile-current-num-closures 0
522 "The number of lexical closures that close over `byte-compile-current-heap-environment'.")
523
456(defvar byte-compile-tag-number 0) 524(defvar byte-compile-tag-number 0)
457(defvar byte-compile-output nil 525(defvar byte-compile-output nil
458 "Alist describing contents to put in byte code string. 526 "Alist describing contents to put in byte code string.
@@ -498,11 +566,10 @@ Each element is (INDEX . VALUE)")
498 (put 'byte-stack+-info 'tmp-compile-time-value nil))) 566 (put 'byte-stack+-info 'tmp-compile-time-value nil)))
499 567
500 568
501;; unused: 0-7
502
503;; These opcodes are special in that they pack their argument into the 569;; These opcodes are special in that they pack their argument into the
504;; opcode word. 570;; opcode word.
505;; 571;;
572(byte-defop 0 1 byte-stack-ref "for stack reference")
506(byte-defop 8 1 byte-varref "for variable reference") 573(byte-defop 8 1 byte-varref "for variable reference")
507(byte-defop 16 -1 byte-varset "for setting a variable") 574(byte-defop 16 -1 byte-varset "for setting a variable")
508(byte-defop 24 -1 byte-varbind "for binding a variable") 575(byte-defop 24 -1 byte-varbind "for binding a variable")
@@ -664,11 +731,28 @@ otherwise pop it")
664(byte-defop 168 0 byte-integerp) 731(byte-defop 168 0 byte-integerp)
665 732
666;; unused: 169-174 733;; unused: 169-174
734
667(byte-defop 175 nil byte-listN) 735(byte-defop 175 nil byte-listN)
668(byte-defop 176 nil byte-concatN) 736(byte-defop 176 nil byte-concatN)
669(byte-defop 177 nil byte-insertN) 737(byte-defop 177 nil byte-insertN)
670 738
671;; unused: 178-191 739(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte
740(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes
741(byte-defop 180 1 byte-vec-ref) ; vector offset in following one byte
742(byte-defop 181 -1 byte-vec-set) ; vector offset in following one byte
743
744;; if (following one byte & 0x80) == 0
745;; discard (following one byte & 0x7F) stack entries
746;; else
747;; discard (following one byte & 0x7F) stack entries _underneath_ the top of stack
748;; (that is, if the operand = 0x83, ... X Y Z T => ... T)
749(byte-defop 182 nil byte-discardN)
750;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into
751;; `byte-discardN' with the high bit in the operand set (by
752;; `byte-compile-lapcode').
753(defconst byte-discardN-preserve-tos byte-discardN)
754
755;; unused: 182-191
672 756
673(byte-defop 192 1 byte-constant "for reference to a constant") 757(byte-defop 192 1 byte-constant "for reference to a constant")
674;; codes 193-255 are consumed by byte-constant. 758;; codes 193-255 are consumed by byte-constant.
@@ -715,71 +799,108 @@ otherwise pop it")
715;; front of the constants-vector than the constant-referencing instructions. 799;; front of the constants-vector than the constant-referencing instructions.
716;; Also, this lets us notice references to free variables. 800;; Also, this lets us notice references to free variables.
717 801
802(defmacro byte-compile-push-bytecodes (&rest args)
803 "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
804ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
805BYTES and PC are updated after evaluating all the arguments."
806 (let ((byte-exprs (butlast args 2))
807 (bytes-var (car (last args 2)))
808 (pc-var (car (last args))))
809 `(setq ,bytes-var ,(if (null (cdr byte-exprs))
810 `(cons ,@byte-exprs ,bytes-var)
811 `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
812 ,pc-var (+ ,(length byte-exprs) ,pc-var))))
813
814(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
815 "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
816CONST2 may be evaulated multiple times."
817 `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
818 ,bytes ,pc))
819
718(defun byte-compile-lapcode (lap) 820(defun byte-compile-lapcode (lap)
719 "Turns lapcode into bytecode. The lapcode is destroyed." 821 "Turns lapcode into bytecode. The lapcode is destroyed."
720 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. 822 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
721 (let ((pc 0) ; Program counter 823 (let ((pc 0) ; Program counter
722 op off ; Operation & offset 824 op off ; Operation & offset
825 opcode ; numeric value of OP
723 (bytes '()) ; Put the output bytes here 826 (bytes '()) ; Put the output bytes here
724 (patchlist nil)) ; List of tags and goto's to patch 827 (patchlist nil)) ; List of gotos to patch
725 (while lap 828 (dolist (lap-entry lap)
726 (setq op (car (car lap)) 829 (setq op (car lap-entry)
727 off (cdr (car lap))) 830 off (cdr lap-entry))
728 (cond ((not (symbolp op)) 831 (cond ((not (symbolp op))
729 (error "Non-symbolic opcode `%s'" op)) 832 (error "Non-symbolic opcode `%s'" op))
730 ((eq op 'TAG) 833 ((eq op 'TAG)
731 (setcar off pc) 834 (setcar off pc))
732 (setq patchlist (cons off patchlist))) 835 ((null op)
733 ((memq op byte-goto-ops) 836 ;; a no-op added by `byte-compile-delay-out'
734 (setq pc (+ pc 3)) 837 (unless (zerop off)
735 (setq bytes (cons (cons pc (cdr off)) 838 (error
736 (cons nil 839 "Placeholder added by `byte-compile-delay-out' not filled in.")
737 (cons (symbol-value op) bytes)))) 840 ))
738 (setq patchlist (cons bytes patchlist)))
739 (t 841 (t
740 (setq bytes 842 (if (eq op 'byte-discardN-preserve-tos)
741 (cond ((cond ((consp off) 843 ;; byte-discardN-preserve-tos is a psuedo op, which is actually
742 ;; Variable or constant reference 844 ;; the same as byte-discardN with a modified argument
743 (setq off (cdr off)) 845 (setq opcode byte-discardN)
744 (eq op 'byte-constant))) 846 (setq opcode (symbol-value op)))
745 (cond ((< off byte-constant-limit) 847 (cond ((memq op byte-goto-ops)
746 (setq pc (1+ pc)) 848 ;; goto
747 (cons (+ byte-constant off) bytes)) 849 (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
748 (t 850 (push bytes patchlist))
749 (setq pc (+ 3 pc)) 851 ((and (consp off)
750 (cons (lsh off -8) 852 ;; Variable or constant reference
751 (cons (logand off 255) 853 (progn (setq off (cdr off))
752 (cons byte-constant2 bytes)))))) 854 (eq op 'byte-constant)))
753 ((<= byte-listN (symbol-value op)) 855 ;; constant ref
754 (setq pc (+ 2 pc)) 856 (if (< off byte-constant-limit)
755 (cons off (cons (symbol-value op) bytes))) 857 (byte-compile-push-bytecodes (+ byte-constant off)
756 ((< off 6) 858 bytes pc)
757 (setq pc (1+ pc)) 859 (byte-compile-push-bytecode-const2 byte-constant2 off
758 (cons (+ (symbol-value op) off) bytes)) 860 bytes pc)))
759 ((< off 256) 861 ((and (= opcode byte-stack-set)
760 (setq pc (+ 2 pc)) 862 (> off 255))
761 (cons off (cons (+ (symbol-value op) 6) bytes))) 863 ;; Use the two-byte version of byte-stack-set if the
762 (t 864 ;; offset is too large for the normal version.
763 (setq pc (+ 3 pc)) 865 (byte-compile-push-bytecode-const2 byte-stack-set2 off
764 (cons (lsh off -8) 866 bytes pc))
765 (cons (logand off 255) 867 ((and (>= opcode byte-listN)
766 (cons (+ (symbol-value op) 7) 868 (< opcode byte-discardN))
767 bytes)))))))) 869 ;; These insns all put their operand into one extra byte.
768 (setq lap (cdr lap))) 870 (byte-compile-push-bytecodes opcode off bytes pc))
871 ((= opcode byte-discardN)
872 ;; byte-discardN is wierd in that it encodes a flag in the
873 ;; top bit of its one-byte argument. If the argument is
874 ;; too large to fit in 7 bits, the opcode can be repeated.
875 (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
876 (while (> off #x7f)
877 (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc)
878 (setq off (- off #x7f)))
879 (byte-compile-push-bytecodes opcode (logior off flag) bytes pc)))
880 ((null off)
881 ;; opcode that doesn't use OFF
882 (byte-compile-push-bytecodes opcode bytes pc))
883 ;; The following three cases are for the special
884 ;; insns that encode their operand into 0, 1, or 2
885 ;; extra bytes depending on its magnitude.
886 ((< off 6)
887 (byte-compile-push-bytecodes (+ opcode off) bytes pc))
888 ((< off 256)
889 (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
890 (t
891 (byte-compile-push-bytecode-const2 (+ opcode 7) off
892 bytes pc))))))
769 ;;(if (not (= pc (length bytes))) 893 ;;(if (not (= pc (length bytes)))
770 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) 894 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
771 ;; Patch PC into jumps 895
772 (let (bytes) 896 ;; Patch tag PCs into absolute jumps
773 (while patchlist 897 (dolist (bytes-tail patchlist)
774 (setq bytes (car patchlist)) 898 (setq pc (caar bytes-tail)) ; Pick PC from goto's tag
775 (cond ((atom (car bytes))) ; Tag 899 (setcar (cdr bytes-tail) (logand pc 255))
776 (t ; Absolute jump 900 (setcar bytes-tail (lsh pc -8))
777 (setq pc (car (cdr (car bytes)))) ; Pick PC from tag 901 ;; FIXME: Replace this by some workaround.
778 (setcar (cdr bytes) (logand pc 255)) 902 (if (> (car bytes) 255) (error "Bytecode overflow")))
779 (setcar bytes (lsh pc -8)) 903
780 ;; FIXME: Replace this by some workaround.
781 (if (> (car bytes) 255) (error "Bytecode overflow"))))
782 (setq patchlist (cdr patchlist))))
783 (apply 'unibyte-string (nreverse bytes)))) 904 (apply 'unibyte-string (nreverse bytes))))
784 905
785 906
@@ -2073,18 +2194,16 @@ list that represents a doc string reference.
2073(defun byte-compile-file-form (form) 2194(defun byte-compile-file-form (form)
2074 (let ((byte-compile-current-form nil) ; close over this for warnings. 2195 (let ((byte-compile-current-form nil) ; close over this for warnings.
2075 bytecomp-handler) 2196 bytecomp-handler)
2076 (cond 2197 (setq form (macroexpand-all form byte-compile-macro-environment))
2077 ((not (consp form)) 2198 (cond ((not (consp form))
2078 (byte-compile-keep-pending form)) 2199 (byte-compile-keep-pending form))
2079 ((and (symbolp (car form)) 2200 ((and (symbolp (car form))
2080 (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) 2201 (setq bytecomp-handler (get (car form) 'byte-hunk-handler)))
2081 (cond ((setq form (funcall bytecomp-handler form)) 2202 (cond ((setq form (funcall bytecomp-handler form))
2082 (byte-compile-flush-pending) 2203 (byte-compile-flush-pending)
2083 (byte-compile-output-file-form form)))) 2204 (byte-compile-output-file-form form))))
2084 ((eq form (setq form (macroexpand form byte-compile-macro-environment))) 2205 (t
2085 (byte-compile-keep-pending form)) 2206 (byte-compile-keep-pending form)))))
2086 (t
2087 (byte-compile-file-form form)))))
2088 2207
2089;; Functions and variables with doc strings must be output separately, 2208;; Functions and variables with doc strings must be output separately,
2090;; so make-docfile can recognise them. Most other things can be output 2209;; so make-docfile can recognise them. Most other things can be output
@@ -2096,8 +2215,7 @@ list that represents a doc string reference.
2096 (setq byte-compile-current-form (nth 1 form)) 2215 (setq byte-compile-current-form (nth 1 form))
2097 (byte-compile-warn "defsubst `%s' was used before it was defined" 2216 (byte-compile-warn "defsubst `%s' was used before it was defined"
2098 (nth 1 form))) 2217 (nth 1 form)))
2099 (byte-compile-file-form 2218 (byte-compile-file-form form)
2100 (macroexpand form byte-compile-macro-environment))
2101 ;; Return nil so the form is not output twice. 2219 ;; Return nil so the form is not output twice.
2102 nil) 2220 nil)
2103 2221
@@ -2418,6 +2536,12 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2418 (if macro 2536 (if macro
2419 (setq fun (cdr fun))) 2537 (setq fun (cdr fun)))
2420 (cond ((eq (car-safe fun) 'lambda) 2538 (cond ((eq (car-safe fun) 'lambda)
2539 ;; expand macros
2540 (setq fun
2541 (macroexpand-all fun
2542 byte-compile-initial-macro-environment))
2543 ;; get rid of the `function' quote added by the `lambda' macro
2544 (setq fun (cadr fun))
2421 (setq fun (if macro 2545 (setq fun (if macro
2422 (cons 'macro (byte-compile-lambda fun)) 2546 (cons 'macro (byte-compile-lambda fun))
2423 (byte-compile-lambda fun))) 2547 (byte-compile-lambda fun)))
@@ -2505,6 +2629,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2505 (setq list (cdr list))))) 2629 (setq list (cdr list)))))
2506 2630
2507 2631
2632(autoload 'byte-compile-make-lambda-lexenv "byte-lexbind")
2633
2508;; Byte-compile a lambda-expression and return a valid function. 2634;; Byte-compile a lambda-expression and return a valid function.
2509;; The value is usually a compiled function but may be the original 2635;; The value is usually a compiled function but may be the original
2510;; lambda-expression. 2636;; lambda-expression.
@@ -2561,20 +2687,43 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2561 (byte-compile-warn "malformed interactive spec: %s" 2687 (byte-compile-warn "malformed interactive spec: %s"
2562 (prin1-to-string bytecomp-int))))) 2688 (prin1-to-string bytecomp-int)))))
2563 ;; Process the body. 2689 ;; Process the body.
2564 (let ((compiled (byte-compile-top-level 2690 (let* ((byte-compile-lexical-environment
2565 (cons 'progn bytecomp-body) nil 'lambda))) 2691 ;; If doing lexical binding, push a new lexical environment
2692 ;; containing the args and any closed-over variables.
2693 (and lexical-binding
2694 (byte-compile-make-lambda-lexenv
2695 fun
2696 byte-compile-lexical-environment)))
2697 (is-closure
2698 ;; This is true if we should be making a closure instead of
2699 ;; a simple lambda (because some variables from the
2700 ;; containing lexical environment are closed over).
2701 (and lexical-binding
2702 (byte-compile-closure-initial-lexenv-p
2703 byte-compile-lexical-environment)))
2704 (byte-compile-current-heap-environment nil)
2705 (byte-compile-current-num-closures 0)
2706 (compiled
2707 (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda)))
2566 ;; Build the actual byte-coded function. 2708 ;; Build the actual byte-coded function.
2567 (if (eq 'byte-code (car-safe compiled)) 2709 (if (eq 'byte-code (car-safe compiled))
2568 (apply 'make-byte-code 2710 (let ((code
2569 (append (list bytecomp-arglist) 2711 (apply 'make-byte-code
2570 ;; byte-string, constants-vector, stack depth 2712 (append (list bytecomp-arglist)
2571 (cdr compiled) 2713 ;; byte-string, constants-vector, stack depth
2572 ;; optionally, the doc string. 2714 (cdr compiled)
2573 (if (or bytecomp-doc bytecomp-int) 2715 ;; optionally, the doc string.
2574 (list bytecomp-doc)) 2716 (if (or bytecomp-doc bytecomp-int
2575 ;; optionally, the interactive spec. 2717 lexical-binding)
2576 (if bytecomp-int 2718 (list bytecomp-doc))
2577 (list (nth 1 bytecomp-int))))) 2719 ;; optionally, the interactive spec.
2720 (if (or bytecomp-int lexical-binding)
2721 (list (nth 1 bytecomp-int)))
2722 (if lexical-binding
2723 '(t))))))
2724 (if is-closure
2725 (cons 'closure code)
2726 code))
2578 (setq compiled 2727 (setq compiled
2579 (nconc (if bytecomp-int (list bytecomp-int)) 2728 (nconc (if bytecomp-int (list bytecomp-int))
2580 (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) 2729 (cond ((eq (car-safe compiled) 'progn) (cdr compiled))
@@ -2585,6 +2734,26 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2585 (bytecomp-body (list nil)))) 2734 (bytecomp-body (list nil))))
2586 compiled)))))) 2735 compiled))))))
2587 2736
2737(defun byte-compile-closure-code-p (code)
2738 (eq (car-safe code) 'closure))
2739
2740(defun byte-compile-make-closure (code)
2741 ;; A real closure requires that the constant be curried with an
2742 ;; environment vector to make a closure object.
2743 (if for-effect
2744 (setq for-effect nil)
2745 (byte-compile-push-constant 'curry)
2746 (byte-compile-push-constant code)
2747 (byte-compile-lexical-variable-ref byte-compile-current-heap-environment)
2748 (byte-compile-out 'byte-call 2)))
2749
2750(defun byte-compile-closure (form &optional add-lambda)
2751 (let ((code (byte-compile-lambda form add-lambda)))
2752 (if (byte-compile-closure-code-p code)
2753 (byte-compile-make-closure code)
2754 ;; A simple lambda is just a constant
2755 (byte-compile-constant code))))
2756
2588(defun byte-compile-constants-vector () 2757(defun byte-compile-constants-vector ()
2589 ;; Builds the constants-vector from the current variables and constants. 2758 ;; Builds the constants-vector from the current variables and constants.
2590 ;; This modifies the constants from (const . nil) to (const . offset). 2759 ;; This modifies the constants from (const . nil) to (const . offset).
@@ -2629,17 +2798,51 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2629 (byte-compile-depth 0) 2798 (byte-compile-depth 0)
2630 (byte-compile-maxdepth 0) 2799 (byte-compile-maxdepth 0)
2631 (byte-compile-output nil)) 2800 (byte-compile-output nil))
2632 (if (memq byte-optimize '(t source)) 2801 (if (memq byte-optimize '(t source))
2633 (setq form (byte-optimize-form form for-effect))) 2802 (setq form (byte-optimize-form form for-effect)))
2634 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) 2803 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
2635 (setq form (nth 1 form))) 2804 (setq form (nth 1 form)))
2636 (if (and (eq 'byte-code (car-safe form)) 2805 (if (and (eq 'byte-code (car-safe form))
2637 (not (memq byte-optimize '(t byte))) 2806 (not (memq byte-optimize '(t byte)))
2638 (stringp (nth 1 form)) (vectorp (nth 2 form)) 2807 (stringp (nth 1 form)) (vectorp (nth 2 form))
2639 (natnump (nth 3 form))) 2808 (natnump (nth 3 form)))
2640 form 2809 form
2641 (byte-compile-form form for-effect) 2810 ;; Set up things for a lexically-bound function
2642 (byte-compile-out-toplevel for-effect output-type)))) 2811 (when (and lexical-binding (eq output-type 'lambda))
2812 ;; See how many arguments there are, and set the current stack depth
2813 ;; accordingly
2814 (dolist (var byte-compile-lexical-environment)
2815 (when (byte-compile-lexvar-on-stack-p var)
2816 (setq byte-compile-depth (1+ byte-compile-depth))))
2817 ;; If there are args, output a tag to record the initial
2818 ;; stack-depth for the optimizer
2819 (when (> byte-compile-depth 0)
2820 (byte-compile-out-tag (byte-compile-make-tag)))
2821 ;; If this is the top-level of a lexically bound lambda expression,
2822 ;; perhaps some parameters on stack need to be copied into a heap
2823 ;; environment, so check for them, and do so if necessary.
2824 (let ((lforminfo (byte-compile-make-lforminfo)))
2825 ;; Add any lexical variable that's on the stack to the analysis set.
2826 (dolist (var byte-compile-lexical-environment)
2827 (when (byte-compile-lexvar-on-stack-p var)
2828 (byte-compile-lforminfo-add-var lforminfo (car var) t)))
2829 ;; Analyze the body
2830 (unless (null (byte-compile-lforminfo-vars lforminfo))
2831 (byte-compile-lforminfo-analyze lforminfo form nil nil))
2832 ;; If the analysis revealed some argument need to be in a heap
2833 ;; environment (because they're closed over by an embedded
2834 ;; lambda), put them there.
2835 (setq byte-compile-lexical-environment
2836 (nconc (byte-compile-maybe-push-heap-environment lforminfo)
2837 byte-compile-lexical-environment))
2838 (dolist (arginfo (byte-compile-lforminfo-vars lforminfo))
2839 (when (byte-compile-lvarinfo-closed-over-p arginfo)
2840 (byte-compile-bind (car arginfo)
2841 byte-compile-lexical-environment
2842 lforminfo)))))
2843 ;; Now compile FORM
2844 (byte-compile-form form for-effect)
2845 (byte-compile-out-toplevel for-effect output-type))))
2643 2846
2644(defun byte-compile-out-toplevel (&optional for-effect output-type) 2847(defun byte-compile-out-toplevel (&optional for-effect output-type)
2645 (if for-effect 2848 (if for-effect
@@ -2761,7 +2964,6 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2761;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) 2964;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
2762;; 2965;;
2763(defun byte-compile-form (form &optional for-effect) 2966(defun byte-compile-form (form &optional for-effect)
2764 (setq form (macroexpand form byte-compile-macro-environment))
2765 (cond ((not (consp form)) 2967 (cond ((not (consp form))
2766 (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) 2968 (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
2767 (when (symbolp form) 2969 (when (symbolp form)
@@ -2771,7 +2973,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2771 (when (symbolp form) 2973 (when (symbolp form)
2772 (byte-compile-set-symbol-position form)) 2974 (byte-compile-set-symbol-position form))
2773 (setq for-effect nil)) 2975 (setq for-effect nil))
2774 (t (byte-compile-variable-ref 'byte-varref form)))) 2976 (t
2977 (byte-compile-variable-ref form))))
2775 ((symbolp (car form)) 2978 ((symbolp (car form))
2776 (let* ((bytecomp-fn (car form)) 2979 (let* ((bytecomp-fn (car form))
2777 (bytecomp-handler (get bytecomp-fn 'byte-compile))) 2980 (bytecomp-handler (get bytecomp-fn 'byte-compile)))
@@ -2822,44 +3025,98 @@ That command is designed for interactive use only" bytecomp-fn))
2822 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. 3025 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
2823 (byte-compile-out 'byte-call (length (cdr form)))) 3026 (byte-compile-out 'byte-call (length (cdr form))))
2824 3027
2825(defun byte-compile-variable-ref (base-op bytecomp-var) 3028(defun byte-compile-check-variable (var &optional binding)
2826 (when (symbolp bytecomp-var) 3029 "Do various error checks before a use of the variable VAR.
2827 (byte-compile-set-symbol-position bytecomp-var)) 3030If BINDING is non-nil, VAR is being bound."
2828 (if (or (not (symbolp bytecomp-var)) 3031 (when (symbolp var)
2829 (byte-compile-const-symbol-p bytecomp-var 3032 (byte-compile-set-symbol-position var))
2830 (not (eq base-op 'byte-varref)))) 3033 (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
2831 (if (byte-compile-warning-enabled-p 'constants) 3034 (when (byte-compile-warning-enabled-p 'constants)
2832 (byte-compile-warn 3035 (byte-compile-warn (if binding
2833 (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") 3036 "attempt to let-bind %s `%s`"
2834 ((eq base-op 'byte-varset) "variable assignment to %s `%s'") 3037 "variable reference to %s `%s'")
2835 (t "variable reference to %s `%s'")) 3038 (if (symbolp var) "constant" "nonvariable")
2836 (if (symbolp bytecomp-var) "constant" "nonvariable") 3039 (prin1-to-string var))))
2837 (prin1-to-string bytecomp-var))) 3040 ((and (get var 'byte-obsolete-variable)
2838 (and (get bytecomp-var 'byte-obsolete-variable) 3041 (not (eq var byte-compile-not-obsolete-var)))
2839 (not (memq bytecomp-var byte-compile-not-obsolete-vars)) 3042 (byte-compile-warn-obsolete var))))
2840 (byte-compile-warn-obsolete bytecomp-var)) 3043
2841 (if (eq base-op 'byte-varbind) 3044(defsubst byte-compile-dynamic-variable-op (base-op var)
2842 (push bytecomp-var byte-compile-bound-variables) 3045 (let ((tmp (assq var byte-compile-variables)))
2843 (or (not (byte-compile-warning-enabled-p 'free-vars))
2844 (boundp bytecomp-var)
2845 (memq bytecomp-var byte-compile-bound-variables)
2846 (if (eq base-op 'byte-varset)
2847 (or (memq bytecomp-var byte-compile-free-assignments)
2848 (progn
2849 (byte-compile-warn "assignment to free variable `%s'"
2850 bytecomp-var)
2851 (push bytecomp-var byte-compile-free-assignments)))
2852 (or (memq bytecomp-var byte-compile-free-references)
2853 (progn
2854 (byte-compile-warn "reference to free variable `%s'"
2855 bytecomp-var)
2856 (push bytecomp-var byte-compile-free-references)))))))
2857 (let ((tmp (assq bytecomp-var byte-compile-variables)))
2858 (unless tmp 3046 (unless tmp
2859 (setq tmp (list bytecomp-var)) 3047 (setq tmp (list var))
2860 (push tmp byte-compile-variables)) 3048 (push tmp byte-compile-variables))
2861 (byte-compile-out base-op tmp))) 3049 (byte-compile-out base-op tmp)))
2862 3050
3051(defun byte-compile-dynamic-variable-bind (var)
3052 "Generate code to bind the lexical variable VAR to the top-of-stack value."
3053 (byte-compile-check-variable var t)
3054 (when (byte-compile-warning-enabled-p 'free-vars)
3055 (push var byte-compile-bound-variables))
3056 (byte-compile-dynamic-variable-op 'byte-varbind var))
3057
3058;; This is used when it's know that VAR _definitely_ has a lexical
3059;; binding, and no error-checking should be done.
3060(defun byte-compile-lexical-variable-ref (var)
3061 "Generate code to push the value of the lexical variable VAR on the stack."
3062 (let ((binding (assq var byte-compile-lexical-environment)))
3063 (when (null binding)
3064 (error "Lexical binding not found for `%s'" var))
3065 (if (byte-compile-lexvar-on-stack-p binding)
3066 ;; On the stack
3067 (byte-compile-stack-ref (byte-compile-lexvar-offset binding))
3068 ;; In a heap environment vector; first push the vector on the stack
3069 (byte-compile-lexical-variable-ref
3070 (byte-compile-lexvar-environment binding))
3071 ;; Now get the value from it
3072 (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding)))))
3073
3074(defun byte-compile-variable-ref (var)
3075 "Generate code to push the value of the variable VAR on the stack."
3076 (byte-compile-check-variable var)
3077 (let ((lex-binding (assq var byte-compile-lexical-environment)))
3078 (if lex-binding
3079 ;; VAR is lexically bound
3080 (if (byte-compile-lexvar-on-stack-p lex-binding)
3081 ;; On the stack
3082 (byte-compile-stack-ref (byte-compile-lexvar-offset lex-binding))
3083 ;; In a heap environment vector
3084 (byte-compile-lexical-variable-ref
3085 (byte-compile-lexvar-environment lex-binding))
3086 (byte-compile-out 'byte-vec-ref
3087 (byte-compile-lexvar-offset lex-binding)))
3088 ;; VAR is dynamically bound
3089 (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
3090 (boundp var)
3091 (memq var byte-compile-bound-variables)
3092 (memq var byte-compile-free-references))
3093 (byte-compile-warn "reference to free variable `%s'" var)
3094 (push var byte-compile-free-references))
3095 (byte-compile-dynamic-variable-op 'byte-varref var))))
3096
3097(defun byte-compile-variable-set (var)
3098 "Generate code to set the variable VAR from the top-of-stack value."
3099 (byte-compile-check-variable var)
3100 (let ((lex-binding (assq var byte-compile-lexical-environment)))
3101 (if lex-binding
3102 ;; VAR is lexically bound
3103 (if (byte-compile-lexvar-on-stack-p lex-binding)
3104 ;; On the stack
3105 (byte-compile-stack-set (byte-compile-lexvar-offset lex-binding))
3106 ;; In a heap environment vector
3107 (byte-compile-lexical-variable-ref
3108 (byte-compile-lexvar-environment lex-binding))
3109 (byte-compile-out 'byte-vec-set
3110 (byte-compile-lexvar-offset lex-binding)))
3111 ;; VAR is dynamically bound
3112 (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
3113 (boundp var)
3114 (memq var byte-compile-bound-variables)
3115 (memq var byte-compile-free-assignments))
3116 (byte-compile-warn "assignment to free variable `%s'" var)
3117 (push var byte-compile-free-assignments))
3118 (byte-compile-dynamic-variable-op 'byte-varset var))))
3119
2863(defmacro byte-compile-get-constant (const) 3120(defmacro byte-compile-get-constant (const)
2864 `(or (if (stringp ,const) 3121 `(or (if (stringp ,const)
2865 ;; In a string constant, treat properties as significant. 3122 ;; In a string constant, treat properties as significant.
@@ -2886,6 +3143,25 @@ That command is designed for interactive use only" bytecomp-fn))
2886 (let ((for-effect nil)) 3143 (let ((for-effect nil))
2887 (inline (byte-compile-constant const)))) 3144 (inline (byte-compile-constant const))))
2888 3145
3146(defun byte-compile-push-unknown-constant (&optional id)
3147 "Generate code to push a `constant' who's value isn't known yet.
3148A tag is returned which may then later be passed to
3149`byte-compile-resolve-unknown-constant' to finalize the value.
3150The optional argument ID is a tag returned by an earlier call to
3151`byte-compile-push-unknown-constant', in which case the same constant is
3152pushed again."
3153 (unless id
3154 (setq id (list (make-symbol "unknown")))
3155 (push id byte-compile-constants))
3156 (byte-compile-out 'byte-constant id)
3157 id)
3158
3159(defun byte-compile-resolve-unknown-constant (id value)
3160 "Give an `unknown constant' a value.
3161ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE
3162is the value it should have."
3163 (setcar id value))
3164
2889 3165
2890;; Compile those primitive ordinary functions 3166;; Compile those primitive ordinary functions
2891;; which have special byte codes just for speed. 3167;; which have special byte codes just for speed.
@@ -3089,8 +3365,39 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3089(defun byte-compile-noop (form) 3365(defun byte-compile-noop (form)
3090 (byte-compile-constant nil)) 3366 (byte-compile-constant nil))
3091 3367
3092(defun byte-compile-discard () 3368(defun byte-compile-discard (&optional num preserve-tos)
3093 (byte-compile-out 'byte-discard 0)) 3369 "Output byte codes to discard the NUM entries at the top of the stack (NUM defaults to 1).
3370If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were
3371popped before discarding the num values, and then pushed back again after
3372discarding."
3373 (if (and (null num) (not preserve-tos))
3374 ;; common case
3375 (byte-compile-out 'byte-discard)
3376 ;; general case
3377 (unless num
3378 (setq num 1))
3379 (when (and preserve-tos (> num 0))
3380 ;; Preserve the top-of-stack value by writing it directly to the stack
3381 ;; location which will be at the top-of-stack after popping.
3382 (byte-compile-stack-set (1- (- byte-compile-depth num)))
3383 ;; Now we actually discard one less value, since we want to keep
3384 ;; the eventual TOS
3385 (setq num (1- num)))
3386 (while (> num 0)
3387 (byte-compile-out 'byte-discard)
3388 (setq num (1- num)))))
3389
3390(defun byte-compile-stack-ref (stack-pos)
3391 "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack."
3392 (if (= byte-compile-depth (1+ stack-pos))
3393 ;; A simple optimization
3394 (byte-compile-out 'byte-dup)
3395 ;; normal case
3396 (byte-compile-out 'byte-stack-ref stack-pos)))
3397
3398(defun byte-compile-stack-set (stack-pos)
3399 "Output byte codes to store the top-of-stack value at position STACK-POS in the stack."
3400 (byte-compile-out 'byte-stack-set stack-pos))
3094 3401
3095 3402
3096;; Compile a function that accepts one or more args and is right-associative. 3403;; Compile a function that accepts one or more args and is right-associative.
@@ -3249,40 +3556,14 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3249 the syntax (function (lambda (...) ...)) instead."))))) 3556 the syntax (function (lambda (...) ...)) instead.")))))
3250 (byte-compile-two-args form)) 3557 (byte-compile-two-args form))
3251 3558
3252(defun byte-compile-funarg (form)
3253 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
3254 ;; for cases where it's guaranteed that first arg will be used as a lambda.
3255 (byte-compile-normal-call
3256 (let ((fn (nth 1 form)))
3257 (if (and (eq (car-safe fn) 'quote)
3258 (eq (car-safe (nth 1 fn)) 'lambda))
3259 (cons (car form)
3260 (cons (cons 'function (cdr fn))
3261 (cdr (cdr form))))
3262 form))))
3263
3264(defun byte-compile-funarg-2 (form)
3265 ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..)))
3266 ;; for cases where it's guaranteed that second arg will be used as a lambda.
3267 (byte-compile-normal-call
3268 (let ((fn (nth 2 form)))
3269 (if (and (eq (car-safe fn) 'quote)
3270 (eq (car-safe (nth 1 fn)) 'lambda))
3271 (cons (car form)
3272 (cons (nth 1 form)
3273 (cons (cons 'function (cdr fn))
3274 (cdr (cdr (cdr form))))))
3275 form))))
3276
3277;; (function foo) must compile like 'foo, not like (symbol-function 'foo). 3559;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
3278;; Otherwise it will be incompatible with the interpreter, 3560;; Otherwise it will be incompatible with the interpreter,
3279;; and (funcall (function foo)) will lose with autoloads. 3561;; and (funcall (function foo)) will lose with autoloads.
3280 3562
3281(defun byte-compile-function-form (form) 3563(defun byte-compile-function-form (form)
3282 (byte-compile-constant 3564 (if (symbolp (nth 1 form))
3283 (cond ((symbolp (nth 1 form)) 3565 (byte-compile-constant (nth 1 form))
3284 (nth 1 form)) 3566 (byte-compile-closure (nth 1 form))))
3285 ((byte-compile-lambda (nth 1 form))))))
3286 3567
3287(defun byte-compile-indent-to (form) 3568(defun byte-compile-indent-to (form)
3288 (let ((len (length form))) 3569 (let ((len (length form)))
@@ -3326,7 +3607,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3326 (byte-compile-form (car (cdr bytecomp-args))) 3607 (byte-compile-form (car (cdr bytecomp-args)))
3327 (or for-effect (cdr (cdr bytecomp-args)) 3608 (or for-effect (cdr (cdr bytecomp-args))
3328 (byte-compile-out 'byte-dup 0)) 3609 (byte-compile-out 'byte-dup 0))
3329 (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) 3610 (byte-compile-variable-set (car bytecomp-args))
3330 (setq bytecomp-args (cdr (cdr bytecomp-args)))) 3611 (setq bytecomp-args (cdr (cdr bytecomp-args))))
3331 ;; (setq), with no arguments. 3612 ;; (setq), with no arguments.
3332 (byte-compile-form nil for-effect)) 3613 (byte-compile-form nil for-effect))
@@ -3392,16 +3673,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3392(byte-defop-compiler-1 or) 3673(byte-defop-compiler-1 or)
3393(byte-defop-compiler-1 while) 3674(byte-defop-compiler-1 while)
3394(byte-defop-compiler-1 funcall) 3675(byte-defop-compiler-1 funcall)
3395(byte-defop-compiler-1 apply byte-compile-funarg)
3396(byte-defop-compiler-1 mapcar byte-compile-funarg)
3397(byte-defop-compiler-1 mapatoms byte-compile-funarg)
3398(byte-defop-compiler-1 mapconcat byte-compile-funarg)
3399(byte-defop-compiler-1 mapc byte-compile-funarg)
3400(byte-defop-compiler-1 maphash byte-compile-funarg)
3401(byte-defop-compiler-1 map-char-table byte-compile-funarg)
3402(byte-defop-compiler-1 map-char-table byte-compile-funarg-2)
3403;; map-charset-chars should be funarg but has optional third arg
3404(byte-defop-compiler-1 sort byte-compile-funarg-2)
3405(byte-defop-compiler-1 let) 3676(byte-defop-compiler-1 let)
3406(byte-defop-compiler-1 let*) 3677(byte-defop-compiler-1 let*)
3407 3678
@@ -3583,7 +3854,14 @@ that suppresses all warnings during execution of BODY."
3583 3854
3584(defun byte-compile-while (form) 3855(defun byte-compile-while (form)
3585 (let ((endtag (byte-compile-make-tag)) 3856 (let ((endtag (byte-compile-make-tag))
3586 (looptag (byte-compile-make-tag))) 3857 (looptag (byte-compile-make-tag))
3858 ;; Heap environments can't be shared between a loop and its
3859 ;; enclosing environment (because any lexical variables bound
3860 ;; inside the loop should have an independent value for each
3861 ;; iteration). Setting `byte-compile-current-num-closures' to
3862 ;; an invalid value causes the code that tries to merge
3863 ;; environments to not do so.
3864 (byte-compile-current-num-closures -1))
3587 (byte-compile-out-tag looptag) 3865 (byte-compile-out-tag looptag)
3588 (byte-compile-form (car (cdr form))) 3866 (byte-compile-form (car (cdr form)))
3589 (byte-compile-goto-if nil for-effect endtag) 3867 (byte-compile-goto-if nil for-effect endtag)
@@ -3596,34 +3874,116 @@ that suppresses all warnings during execution of BODY."
3596 (mapc 'byte-compile-form (cdr form)) 3874 (mapc 'byte-compile-form (cdr form))
3597 (byte-compile-out 'byte-call (length (cdr (cdr form))))) 3875 (byte-compile-out 'byte-call (length (cdr (cdr form)))))
3598 3876
3877
3878;; let binding
3879
3880;; All other lexical-binding functions are guarded by a non-nil return
3881;; value from `byte-compile-compute-lforminfo', so they needn't be
3882;; autoloaded.
3883(autoload 'byte-compile-compute-lforminfo "byte-lexbind")
3884
3885(defun byte-compile-push-binding-init (clause init-lexenv lforminfo)
3886 "Emit byte-codes to push the initialization value for CLAUSE on the stack.
3887INIT-LEXENV is the lexical environment created for initializations
3888already done for this form.
3889LFORMINFO should be information about lexical variables being bound.
3890Return INIT-LEXENV updated to include the newest initialization, or nil
3891if LFORMINFO is nil (meaning all bindings are dynamic)."
3892 (let* ((var (if (consp clause) (car clause) clause))
3893 (vinfo
3894 (and lforminfo (assq var (byte-compile-lforminfo-vars lforminfo))))
3895 (unused (and vinfo (zerop (cadr vinfo)))))
3896 (unless (and unused (symbolp clause))
3897 (when (and lforminfo (not unused))
3898 ;; We record the stack position even of dynamic bindings and
3899 ;; variables in non-stack lexical environments; we'll put
3900 ;; them in the proper place below.
3901 (push (byte-compile-make-lexvar var byte-compile-depth) init-lexenv))
3902 (if (consp clause)
3903 (byte-compile-form (cadr clause) unused)
3904 (byte-compile-push-constant nil))))
3905 init-lexenv)
3599 3906
3600(defun byte-compile-let (form) 3907(defun byte-compile-let (form)
3601 ;; First compute the binding values in the old scope. 3908 "Generate code for the `let' form FORM."
3602 (let ((varlist (car (cdr form)))) 3909 (let ((clauses (cadr form))
3603 (dolist (var varlist) 3910 (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))
3604 (if (consp var) 3911 (init-lexenv nil)
3605 (byte-compile-form (car (cdr var))) 3912 ;; bind these to restrict the scope of any changes
3606 (byte-compile-push-constant nil)))) 3913 (byte-compile-current-heap-environment
3607 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope 3914 byte-compile-current-heap-environment)
3608 (varlist (reverse (car (cdr form))))) 3915 (byte-compile-current-num-closures byte-compile-current-num-closures))
3609 (dolist (var varlist) 3916 (when (and lforminfo (byte-compile-non-stack-bindings-p clauses lforminfo))
3610 (byte-compile-variable-ref 'byte-varbind 3917 ;; Some of the variables we're binding are lexical variables on
3611 (if (consp var) (car var) var))) 3918 ;; the stack, but not all. As much as we can, rearrange the list
3612 (byte-compile-body-do-effect (cdr (cdr form))) 3919 ;; so that non-stack lexical variables and dynamically bound
3613 (byte-compile-out 'byte-unbind (length (car (cdr form)))))) 3920 ;; variables come last, which allows slightly more optimal
3921 ;; byte-code for binding them.
3922 (setq clauses (byte-compile-rearrange-let-clauses clauses lforminfo)))
3923 ;; If necessary, create a new heap environment to hold some of the
3924 ;; variables bound here.
3925 (when lforminfo
3926 (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo)))
3927 ;; First compute the binding values in the old scope.
3928 (dolist (clause clauses)
3929 (setq init-lexenv
3930 (byte-compile-push-binding-init clause init-lexenv lforminfo)))
3931 ;; Now do the bindings, execute the body, and undo the bindings
3932 (let ((byte-compile-bound-variables byte-compile-bound-variables)
3933 (byte-compile-lexical-environment byte-compile-lexical-environment)
3934 (preserve-body-value (not for-effect)))
3935 (dolist (clause (reverse clauses))
3936 (let ((var (if (consp clause) (car clause) clause)))
3937 (cond ((null lforminfo)
3938 ;; If there are no lexical bindings, we can do things simply.
3939 (byte-compile-dynamic-variable-bind var))
3940 ((byte-compile-bind var init-lexenv lforminfo)
3941 (pop init-lexenv)))))
3942 ;; Emit the body
3943 (byte-compile-body-do-effect (cdr (cdr form)))
3944 ;; Unbind the variables
3945 (if lforminfo
3946 ;; Unbind both lexical and dynamic variables
3947 (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value)
3948 ;; Unbind dynamic variables
3949 (byte-compile-out 'byte-unbind (length clauses))))))
3614 3950
3615(defun byte-compile-let* (form) 3951(defun byte-compile-let* (form)
3616 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope 3952 "Generate code for the `let*' form FORM."
3617 (varlist (copy-sequence (car (cdr form))))) 3953 (let ((clauses (cadr form))
3618 (dolist (var varlist) 3954 (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))
3619 (if (atom var) 3955 (init-lexenv nil)
3620 (byte-compile-push-constant nil) 3956 (preserve-body-value (not for-effect))
3621 (byte-compile-form (car (cdr var))) 3957 ;; bind these to restrict the scope of any changes
3622 (setq var (car var))) 3958 (byte-compile-bound-variables byte-compile-bound-variables)
3623 (byte-compile-variable-ref 'byte-varbind var)) 3959 (byte-compile-lexical-environment byte-compile-lexical-environment)
3960 (byte-compile-current-heap-environment
3961 byte-compile-current-heap-environment)
3962 (byte-compile-current-num-closures byte-compile-current-num-closures))
3963 ;; If necessary, create a new heap environment to hold some of the
3964 ;; variables bound here.
3965 (when lforminfo
3966 (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo)))
3967 ;; Bind the variables
3968 (dolist (clause clauses)
3969 (setq init-lexenv
3970 (byte-compile-push-binding-init clause init-lexenv lforminfo))
3971 (let ((var (if (consp clause) (car clause) clause)))
3972 (cond ((null lforminfo)
3973 ;; If there are no lexical bindings, we can do things simply.
3974 (byte-compile-dynamic-variable-bind var))
3975 ((byte-compile-bind var init-lexenv lforminfo)
3976 (pop init-lexenv)))))
3977 ;; Emit the body
3624 (byte-compile-body-do-effect (cdr (cdr form))) 3978 (byte-compile-body-do-effect (cdr (cdr form)))
3625 (byte-compile-out 'byte-unbind (length (car (cdr form)))))) 3979 ;; Unbind the variables
3980 (if lforminfo
3981 ;; Unbind both lexical and dynamic variables
3982 (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value)
3983 ;; Unbind dynamic variables
3984 (byte-compile-out 'byte-unbind (length clauses)))))
3626 3985
3986
3627 3987
3628(byte-defop-compiler-1 /= byte-compile-negated) 3988(byte-defop-compiler-1 /= byte-compile-negated)
3629(byte-defop-compiler-1 atom byte-compile-negated) 3989(byte-defop-compiler-1 atom byte-compile-negated)
@@ -3646,6 +4006,7 @@ that suppresses all warnings during execution of BODY."
3646 "Compiler error: `%s' has no `byte-compile-negated-op' property" 4006 "Compiler error: `%s' has no `byte-compile-negated-op' property"
3647 (car form))) 4007 (car form)))
3648 (cdr form)))) 4008 (cdr form))))
4009
3649 4010
3650;;; other tricky macro-like special-forms 4011;;; other tricky macro-like special-forms
3651 4012
@@ -3766,28 +4127,28 @@ that suppresses all warnings during execution of BODY."
3766 (byte-compile-set-symbol-position (car form)) 4127 (byte-compile-set-symbol-position (car form))
3767 (byte-compile-set-symbol-position 'defun) 4128 (byte-compile-set-symbol-position 'defun)
3768 (error "defun name must be a symbol, not %s" (car form))) 4129 (error "defun name must be a symbol, not %s" (car form)))
3769 ;; We prefer to generate a defalias form so it will record the function 4130 (let ((for-effect nil))
3770 ;; definition just like interpreting a defun. 4131 (byte-compile-push-constant 'defalias)
3771 (byte-compile-form 4132 (byte-compile-push-constant (nth 1 form))
3772 (list 'defalias 4133 (byte-compile-closure (cdr (cdr form)) t))
3773 (list 'quote (nth 1 form)) 4134 (byte-compile-out 'byte-call 2))
3774 (byte-compile-byte-code-maker
3775 (byte-compile-lambda (cdr (cdr form)) t)))
3776 t)
3777 (byte-compile-constant (nth 1 form)))
3778 4135
3779(defun byte-compile-defmacro (form) 4136(defun byte-compile-defmacro (form)
3780 ;; This is not used for file-level defmacros with doc strings. 4137 ;; This is not used for file-level defmacros with doc strings.
3781 (byte-compile-body-do-effect 4138 ;; FIXME handle decls, use defalias?
3782 (let ((decls (byte-compile-defmacro-declaration form)) 4139 (let ((decls (byte-compile-defmacro-declaration form))
3783 (code (byte-compile-byte-code-maker 4140 (code (byte-compile-lambda (cdr (cdr form)) t))
3784 (byte-compile-lambda (cdr (cdr form)) t)))) 4141 (for-effect nil))
3785 `((defalias ',(nth 1 form) 4142 (byte-compile-push-constant (nth 1 form))
3786 ,(if (eq (car-safe code) 'make-byte-code) 4143 (if (not (byte-compile-closure-code-p code))
3787 `(cons 'macro ,code) 4144 ;; simple lambda
3788 `'(macro . ,(eval code)))) 4145 (byte-compile-push-constant (cons 'macro code))
3789 ,@decls 4146 (byte-compile-push-constant 'macro)
3790 ',(nth 1 form))))) 4147 (byte-compile-make-closure code)
4148 (byte-compile-out 'byte-cons))
4149 (byte-compile-out 'byte-fset)
4150 (byte-compile-discard))
4151 (byte-compile-constant (nth 1 form)))
3791 4152
3792(defun byte-compile-defvar (form) 4153(defun byte-compile-defvar (form)
3793 ;; This is not used for file-level defvar/consts with doc strings. 4154 ;; This is not used for file-level defvar/consts with doc strings.
@@ -3813,7 +4174,7 @@ that suppresses all warnings during execution of BODY."
3813 ;; Put the defined variable in this library's load-history entry 4174 ;; Put the defined variable in this library's load-history entry
3814 ;; just as a real defvar would, but only in top-level forms. 4175 ;; just as a real defvar would, but only in top-level forms.
3815 (when (and (cddr form) (null byte-compile-current-form)) 4176 (when (and (cddr form) (null byte-compile-current-form))
3816 `(push ',var current-load-list)) 4177 `(setq current-load-list (cons ',var current-load-list)))
3817 (when (> (length form) 3) 4178 (when (> (length form) 3)
3818 (when (and string (not (stringp string))) 4179 (when (and string (not (stringp string)))
3819 (byte-compile-warn "third arg to `%s %s' is not a string: %s" 4180 (byte-compile-warn "third arg to `%s %s' is not a string: %s"
@@ -3935,23 +4296,74 @@ that suppresses all warnings during execution of BODY."
3935 (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) 4296 (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
3936 (1- byte-compile-depth)))) 4297 (1- byte-compile-depth))))
3937 4298
3938(defun byte-compile-out (opcode offset) 4299(defun byte-compile-stack-adjustment (op operand)
3939 (push (cons opcode offset) byte-compile-output) 4300 "Return the amount by which an operation adjusts the stack.
3940 (cond ((eq opcode 'byte-call) 4301OP and OPERAND are as passed to `byte-compile-out'."
3941 (setq byte-compile-depth (- byte-compile-depth offset))) 4302 (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos))
3942 ((eq opcode 'byte-return) 4303 ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1
3943 ;; This is actually an unnecessary case, because there should be 4304 ;; elements, and the push the result, for a total of -OPERAND.
3944 ;; no more opcodes behind byte-return. 4305 ;; For discardN*, of course, we just pop OPERAND elements.
3945 (setq byte-compile-depth nil)) 4306 (- operand)
3946 (t 4307 (or (aref byte-stack+-info (symbol-value op))
3947 (setq byte-compile-depth (+ byte-compile-depth 4308 ;; Ops with a nil entry in `byte-stack+-info' are byte-codes
3948 (or (aref byte-stack+-info 4309 ;; that take OPERAND values off the stack and push a result, for
3949 (symbol-value opcode)) 4310 ;; a total of 1 - OPERAND
3950 (- (1- offset)))) 4311 (- 1 operand))))
3951 byte-compile-maxdepth (max byte-compile-depth 4312
3952 byte-compile-maxdepth)))) 4313(defun byte-compile-out (op &optional operand)
3953 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) 4314 (push (cons op operand) byte-compile-output)
3954 ) 4315 (if (eq op 'byte-return)
4316 ;; This is actually an unnecessary case, because there should be no
4317 ;; more ops behind byte-return.
4318 (setq byte-compile-depth nil)
4319 (setq byte-compile-depth
4320 (+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
4321 (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
4322 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
4323 ))
4324
4325(defun byte-compile-delay-out (&optional stack-used stack-adjust)
4326 "Add a placeholder to the output, which can be used to later add byte-codes.
4327Return a position tag that can be passed to `byte-compile-delayed-out'
4328to add the delayed byte-codes. STACK-USED is the maximum amount of
4329stack-spaced used by the delayed byte-codes (defaulting to 0), and
4330STACK-ADJUST is the amount by which the later-added code will adjust the
4331stack (defaulting to 0); the byte-codes added later _must_ adjust the
4332stack by this amount! If STACK-ADJUST is 0, then it's not necessary to
4333actually add anything later; the effect as if nothing was added at all."
4334 ;; We just add a no-op to `byte-compile-output', and return a pointer to
4335 ;; the tail of the list; `byte-compile-delayed-out' uses list surgery
4336 ;; to add the byte-codes.
4337 (when stack-used
4338 (setq byte-compile-maxdepth
4339 (max byte-compile-depth (+ byte-compile-depth (or stack-used 0)))))
4340 (when stack-adjust
4341 (setq byte-compile-depth
4342 (+ byte-compile-depth stack-adjust)))
4343 (push (cons nil (or stack-adjust 0)) byte-compile-output))
4344
4345(defun byte-compile-delayed-out (position op &optional operand)
4346 "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND.
4347POSITION should a position returned by `byte-compile-delay-out'.
4348Return a new position, which can be used to add further operations."
4349 (unless (null (caar position))
4350 (error "Bad POSITION arg to `byte-compile-delayed-out'"))
4351 ;; This is kind of like `byte-compile-out', but we splice into the list
4352 ;; where POSITION is. We don't bother updating `byte-compile-maxdepth'
4353 ;; because that was already done by `byte-compile-delay-out', but we do
4354 ;; update the relative operand stored in the no-op marker currently at
4355 ;; POSITION; since we insert before that marker, this means that if the
4356 ;; caller doesn't insert a sequence of byte-codes that matches the expected
4357 ;; operand passed to `byte-compile-delay-out', then the nop will still have
4358 ;; a non-zero operand when `byte-compile-lapcode' is called, which will
4359 ;; cause an error to be signaled.
4360
4361 ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op
4362 (setcdr (car position)
4363 (- (cdar position) (byte-compile-stack-adjustment op operand)))
4364 ;; Add the new operation onto the list tail at POSITION
4365 (setcdr position (cons (cons op operand) (cdr position)))
4366 position)
3955 4367
3956 4368
3957;;; call tree stuff 4369;;; call tree stuff
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 9899e991e3f..18aa5fde0c8 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -73,19 +73,22 @@ redefine OBJECT if it is a symbol."
73 (let ((macro 'nil) 73 (let ((macro 'nil)
74 (name 'nil) 74 (name 'nil)
75 (doc 'nil) 75 (doc 'nil)
76 (lexical-binding nil)
76 args) 77 args)
77 (while (symbolp obj) 78 (while (symbolp obj)
78 (setq name obj 79 (setq name obj
79 obj (symbol-function obj))) 80 obj (symbol-function obj)))
80 (if (subrp obj) 81 (if (subrp obj)
81 (error "Can't disassemble #<subr %s>" name)) 82 (error "Can't disassemble #<subr %s>" name))
82 (if (and (listp obj) (eq (car obj) 'autoload)) 83 (when (and (listp obj) (eq (car obj) 'autoload))
83 (progn 84 (load (nth 1 obj))
84 (load (nth 1 obj)) 85 (setq obj (symbol-function name)))
85 (setq obj (symbol-function name))))
86 (if (eq (car-safe obj) 'macro) ;handle macros 86 (if (eq (car-safe obj) 'macro) ;handle macros
87 (setq macro t 87 (setq macro t
88 obj (cdr obj))) 88 obj (cdr obj)))
89 (when (and (listp obj) (eq (car obj) 'closure))
90 (setq lexical-binding t)
91 (setq obj (cddr obj)))
89 (if (and (listp obj) (eq (car obj) 'byte-code)) 92 (if (and (listp obj) (eq (car obj) 'byte-code))
90 (setq obj (list 'lambda nil obj))) 93 (setq obj (list 'lambda nil obj)))
91 (if (and (listp obj) (not (eq (car obj) 'lambda))) 94 (if (and (listp obj) (not (eq (car obj) 'lambda)))
@@ -216,7 +219,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
216 (cond ((memq op byte-goto-ops) 219 (cond ((memq op byte-goto-ops)
217 (insert (int-to-string (nth 1 arg)))) 220 (insert (int-to-string (nth 1 arg))))
218 ((memq op '(byte-call byte-unbind 221 ((memq op '(byte-call byte-unbind
219 byte-listN byte-concatN byte-insertN)) 222 byte-listN byte-concatN byte-insertN
223 byte-stack-ref byte-stack-set byte-stack-set2
224 byte-discardN byte-discardN-preserve-tos))
220 (insert (int-to-string arg))) 225 (insert (int-to-string arg)))
221 ((memq op '(byte-varref byte-varset byte-varbind)) 226 ((memq op '(byte-varref byte-varset byte-varbind))
222 (prin1 (car arg) (current-buffer))) 227 (prin1 (car arg) (current-buffer)))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 02477baf74f..1185f79806f 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -701,7 +701,15 @@ If CHAR is not a character, return nil."
701(defun eval-last-sexp-1 (eval-last-sexp-arg-internal) 701(defun eval-last-sexp-1 (eval-last-sexp-arg-internal)
702 "Evaluate sexp before point; print value in minibuffer. 702 "Evaluate sexp before point; print value in minibuffer.
703With argument, print output into current buffer." 703With argument, print output into current buffer."
704 (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) 704 (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))
705 ;; preserve the current lexical environment
706 (internal-interpreter-environment internal-interpreter-environment))
707 ;; Setup the lexical environment if lexical-binding is enabled.
708 ;; Note that `internal-interpreter-environment' _can't_ be both
709 ;; assigned and let-bound above -- it's treated specially (and
710 ;; oddly) by the interpreter!
711 (when lexical-binding
712 (setq internal-interpreter-environment '(t)))
705 (eval-last-sexp-print-value (eval (preceding-sexp))))) 713 (eval-last-sexp-print-value (eval (preceding-sexp)))))
706 714
707 715
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 86e9411b140..9a505b214c8 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -100,6 +100,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
100 (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) 100 (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
101 ;; If definition is a macro, find the function inside it. 101 ;; If definition is a macro, find the function inside it.
102 (if (eq (car-safe def) 'macro) (setq def (cdr def))) 102 (if (eq (car-safe def) 'macro) (setq def (cdr def)))
103 ;; and do the same for interpreted closures
104 (if (eq (car-safe def) 'closure) (setq def (cddr def)))
103 (cond 105 (cond
104 ((byte-code-function-p def) (aref def 0)) 106 ((byte-code-function-p def) (aref def 0))
105 ((eq (car-safe def) 'lambda) (nth 1 def)) 107 ((eq (car-safe def) 'lambda) (nth 1 def))
@@ -190,7 +192,7 @@ if the variable `help-downcase-arguments' is non-nil."
190 doc t t 1))))) 192 doc t t 1)))))
191 193
192(defun help-highlight-arguments (usage doc &rest args) 194(defun help-highlight-arguments (usage doc &rest args)
193 (when usage 195 (when (and usage (string-match "^(" usage))
194 (with-temp-buffer 196 (with-temp-buffer
195 (insert usage) 197 (insert usage)
196 (goto-char (point-min)) 198 (goto-char (point-min))
@@ -347,8 +349,7 @@ suitable file is found, return nil."
347 (pt1 (with-current-buffer (help-buffer) (point))) 349 (pt1 (with-current-buffer (help-buffer) (point)))
348 errtype) 350 errtype)
349 (setq string 351 (setq string
350 (cond ((or (stringp def) 352 (cond ((or (stringp def) (vectorp def))
351 (vectorp def))
352 "a keyboard macro") 353 "a keyboard macro")
353 ((subrp def) 354 ((subrp def)
354 (if (eq 'unevalled (cdr (subr-arity def))) 355 (if (eq 'unevalled (cdr (subr-arity def)))
@@ -356,6 +357,13 @@ suitable file is found, return nil."
356 (concat beg "built-in function"))) 357 (concat beg "built-in function")))
357 ((byte-code-function-p def) 358 ((byte-code-function-p def)
358 (concat beg "compiled Lisp function")) 359 (concat beg "compiled Lisp function"))
360 ((and (funvecp def) (eq (aref def 0) 'curry))
361 (if (symbolp (aref def 1))
362 (format "a curried function calling `%s'" (aref def 1))
363 "a curried function"))
364 ((funvecp def)
365 (format "a function-vector (funvec) of type `%s'"
366 (aref def 0)))
359 ((symbolp def) 367 ((symbolp def)
360 (while (and (fboundp def) 368 (while (and (fboundp def)
361 (symbolp (symbol-function def))) 369 (symbolp (symbol-function def)))
@@ -367,6 +375,8 @@ suitable file is found, return nil."
367 (concat beg "Lisp function")) 375 (concat beg "Lisp function"))
368 ((eq (car-safe def) 'macro) 376 ((eq (car-safe def) 'macro)
369 "a Lisp macro") 377 "a Lisp macro")
378 ((eq (car-safe def) 'closure)
379 (concat beg "Lisp closure"))
370 ((eq (car-safe def) 'autoload) 380 ((eq (car-safe def) 'autoload)
371 (format "%s autoloaded %s" 381 (format "%s autoloaded %s"
372 (if (commandp def) "an interactive" "an") 382 (if (commandp def) "an interactive" "an")
@@ -494,27 +504,42 @@ suitable file is found, return nil."
494 ((or (stringp def) 504 ((or (stringp def)
495 (vectorp def)) 505 (vectorp def))
496 (format "\nMacro: %s" (format-kbd-macro def))) 506 (format "\nMacro: %s" (format-kbd-macro def)))
507 ((and (funvecp def) (eq (aref def 0) 'curry))
508 ;; Describe a curried-function's function and args
509 (let ((slot 0))
510 (mapconcat (lambda (arg)
511 (setq slot (1+ slot))
512 (cond
513 ((= slot 1) "")
514 ((= slot 2)
515 (format " Function: %S" arg))
516 (t
517 (format "Argument %d: %S"
518 (- slot 3) arg))))
519 def
520 "\n")))
521 ((funvecp def) nil)
497 (t "[Missing arglist. Please make a bug report.]"))) 522 (t "[Missing arglist. Please make a bug report.]")))
498 (high (help-highlight-arguments use doc))) 523 (high (help-highlight-arguments use doc)))
499 (let ((fill-begin (point))) 524 (let ((fill-begin (point)))
500 (insert (car high) "\n") 525 (insert (car high) "\n")
501 (fill-region fill-begin (point))) 526 (fill-region fill-begin (point))))
502 (setq doc (cdr high)))) 527 (setq doc (cdr high))))
503 (let* ((obsolete (and 528 (let* ((obsolete (and
504 ;; function might be a lambda construct. 529 ;; function might be a lambda construct.
505 (symbolp function) 530 (symbolp function)
506 (get function 'byte-obsolete-info))) 531 (get function 'byte-obsolete-info)))
507 (use (car obsolete))) 532 (use (car obsolete)))
508 (when obsolete 533 (when obsolete
509 (princ "\nThis function is obsolete") 534 (princ "\nThis function is obsolete")
510 (when (nth 2 obsolete) 535 (when (nth 2 obsolete)
511 (insert (format " since %s" (nth 2 obsolete)))) 536 (insert (format " since %s" (nth 2 obsolete))))
512 (insert (cond ((stringp use) (concat ";\n" use)) 537 (insert (cond ((stringp use) (concat ";\n" use))
513 (use (format ";\nuse `%s' instead." use)) 538 (use (format ";\nuse `%s' instead." use))
514 (t ".")) 539 (t "."))
515 "\n")) 540 "\n"))
516 (insert "\n" 541 (insert "\n"
517 (or doc "Not documented.")))))))) 542 (or doc "Not documented.")))))))
518 543
519 544
520;; Variables 545;; Variables
diff --git a/lisp/subr.el b/lisp/subr.el
index 16ba45f1c74..61a226c20ff 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -427,6 +427,12 @@ Non-strings in LIST are ignored."
427 (setq list (cdr list))) 427 (setq list (cdr list)))
428 list) 428 list)
429 429
430(defmacro with-lexical-binding (&rest body)
431 "Execute the statements in BODY using lexical binding."
432 `(let ((internal-interpreter-environment internal-interpreter-environment))
433 (setq internal-interpreter-environment '(t))
434 ,@body))
435
430(defun assq-delete-all (key alist) 436(defun assq-delete-all (key alist)
431 "Delete from ALIST all elements whose car is `eq' to KEY. 437 "Delete from ALIST all elements whose car is `eq' to KEY.
432Return the modified alist. 438Return the modified alist.
diff --git a/src/ChangeLog.funvec b/src/ChangeLog.funvec
new file mode 100644
index 00000000000..098539f1dd9
--- /dev/null
+++ b/src/ChangeLog.funvec
@@ -0,0 +1,37 @@
12004-05-20 Miles Bader <miles@gnu.org>
2
3 * lisp.h: Declare make_funvec and Ffunvec.
4 (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'.
5 (XSETFUNVEC): Renamed from `XSETCOMPILED'.
6 (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros.
7 (COMPILEDP): Define in terms of funvec macros.
8 (FUNVECP, GC_FUNVECP): Renamed from `COMPILEDP' & `GC_COMPILEDP'.
9 (FUNCTIONP): Use FUNVECP instead of COMPILEDP.
10 * alloc.c (make_funvec, funvec): New functions.
11 (Fmake_byte_code): Make sure the first element is a list.
12
13 * eval.c (Qcurry): New variable.
14 (funcall_funvec, Fcurry): New functions.
15 (syms_of_eval): Initialize them.
16 (funcall_lambda): Handle non-bytecode funvec objects by calling
17 funcall_funvec.
18 (Ffuncall, Feval): Use FUNVECP insetad of COMPILEDP.
19 * lread.c (read1): Return result of read_vector for `#[' syntax
20 directly; read_vector now does any extra work required.
21 (read_vector): Handle both funvec and byte-code objects, converting the
22 type as necessary. `bytecodeflag' argument is now called
23 `read_funvec'.
24 * data.c (Ffunvecp): New function.
25 * doc.c (Fdocumentation): Return nil for unknown funvecs.
26 * fns.c (mapcar1, Felt, concat): Allow funvecs.
27
28 * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled'
29 operators.
30 * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise.
31 * keyboard.c (Fcommand_execute): Likewise.
32 * image.c (parse_image_spec): Likewise.
33 * fns.c (Flength, concat, internal_equal): Likewise.
34 * data.c (Faref, Ftype_of): Likewise.
35 * print.c (print_preprocess, print_object): Likewise.
36
37;; arch-tag: f35a6a00-4a11-4739-a4b6-9cf98296f315
diff --git a/src/ChangeLog.lexbind b/src/ChangeLog.lexbind
new file mode 100644
index 00000000000..c8336d12e9c
--- /dev/null
+++ b/src/ChangeLog.lexbind
@@ -0,0 +1,104 @@
12008-04-23 Miles Bader <miles@gnu.org>
2
3 * eval.c (Ffunctionp): Return nil for special forms.
4 (Qunevalled): New variable.
5 (syms_of_eval): Initialize it.
6
72007-10-18 Miles Bader <miles@gnu.org>
8
9 * eval.c (FletX): Test the type of VARLIST rather than just !NILP.
10 (Flet): Use XCAR instead of Fcar.
11
122007-10-16 Miles Bader <miles@gnu.org>
13
14 * alloc.c (make_funvec, Fpurecopy): Set the pseudo-vector type.
15
162006-02-10 Miles Bader <miles@gnu.org>
17
18 * eval.c (Ffunctionp): Supply new 2nd arg to Findirect_function.
19
202005-03-04 Miles Bader <miles@gnu.org>
21
22 * eval.c (FletX): Update Vinterpreter_lexical_environment for each
23 variable we bind, instead of all at once like `let'.
24
252004-08-09 Miles Bader <miles@gnu.org>
26
27 Changes from merging the funvec patch:
28
29 * eval.c (Feval, Ffuncall): Don't special-case vectors.
30 (funcall_lambda): Use FUNVEC_SIZE.
31 (Fcurry): Remove function.
32
33 Merge funvec patch.
34
352004-04-10 Miles Bader <miles@gnu.org>
36
37 * eval.c (Fspecialp): New function.
38 (syms_of_eval): Initialize it.
39
402004-04-03 Miles Bader <miles@gnu.org>
41
42 * eval.c (Feval): If a variable isn't bound lexically, fall back
43 to looking it up dynamically even if it isn't declared special.
44
452002-08-26 Miles Bader <miles@gnu.org>
46
47 * bytecode.c (Fbyte_code): Fsub1 can GC, so protect it.
48
492002-06-12 Miles Bader <miles@gnu.org>
50
51 Lexical binding changes to the byte-code interpreter:
52
53 * bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, Bvec_ref, Bvec_set)
54 (BdiscardN): New constants.
55 (exec_byte_code): Renamed from `Fbyte_code'.
56 Implement above new bytecodes.
57 Add ARGS-TEMPLATE, NARGS and ARGS parameters, and optionally use
58 them push initial args on the stack.
59 (Fbyte_code): New function, just call `exec_byte_code'.
60 Add additional optional arguments for `exec_byte_code'.
61 (Qand_optional, Qand_rest): New extern declarations.
62 * eval.c (Fcurry, Ffunctionp): New functions.
63 (syms_of_eval): Initialize them.
64 (funcall_lambda): Call `exec_byte_code' instead of Fbyte_code.
65 If a compiled-function object has a `push-args' slot, call the
66 byte-code interpreter without binding any arguments.
67 (Ffuncall): Add support for curried functions.
68 * lisp.h (Fbyte_code): Declare max-args as MANY.
69 (exec_byte_code): New declaration.
70
71 Lexical binding changes to the lisp interpreter:
72
73 * lisp.h (struct Lisp_Symbol): Add `declared_special' field.
74 (apply_lambda): Add new 3rd arg to decl.
75 * alloc.c (Fmake_symbol): Initialize `declared_special' field.
76 * eval.c (Vinterpreter_lexical_environment): New variable.
77 (syms_of_eval): Initialize it.
78 (Fsetq): Modify SYM's lexical binding if appropriate.
79 (Ffunction): Return a closure if within a lexical environment.
80 (Flet, FletX): Lexically bind non-defvar'd variables if inside a
81 lexical environment.
82 (Feval): Return lexical binding of variables, if they have one.
83 Pass current lexical environment to embedded lambdas. Handle closures.
84 (Ffuncall): Pass nil lexical environment to lambdas. Handle closures.
85 (funcall_lambda): Add new LEXENV argument, and lexically bind
86 arguments if it's non-nil. Bind `interpreter-lexenv' if it changed.
87 (apply_lambda): Add new LEXENV argument and pass it to funcall_lambda.
88 (Fdefvaralias, Fdefvar, Fdefconst): Mark the variable as special.
89 (Qinternal_interpreter_environment, Qclosure): New constants.
90 (syms_of_eval): Initialize them.
91 (Fdefun, Fdefmacro): Use a closure if lexical binding is active.
92 * lread.c (defvar_bool, defvar_lisp_nopro, defvar_per_buffer)
93 (defvar_kboard, defvar_int): Mark the variable as special.
94 (Vlexical_binding, Qlexical_binding): New variables.
95 (syms_of_lread): Initialize them.
96 (Fload): Bind `lexically-bound' to nil unless specified otherwise
97 in the file header.
98 (lisp_file_lexically_bound_p): New function.
99 (Qinternal_interpreter_environment): New variable.
100 * doc.c (Qclosure): New extern declaration.
101 (Fdocumentation, store_function_docstring): Handle interpreted
102 closures.
103
104;; arch-tag: 7cf884aa-6b48-40cb-bfca-265a1e99b3c5
diff --git a/src/alloc.c b/src/alloc.c
index e0f07cc5f5a..a23c688043c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3042,6 +3042,39 @@ See also the function `vector'. */)
3042} 3042}
3043 3043
3044 3044
3045/* Return a new `function vector' containing KIND as the first element,
3046 followed by NUM_NIL_SLOTS nil elements, and further elements copied from
3047 the vector PARAMS of length NUM_PARAMS (so the total length of the
3048 resulting vector is 1 + NUM_NIL_SLOTS + NUM_PARAMS).
3049
3050 If NUM_PARAMS is zero, then PARAMS may be NULL.
3051
3052 A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp.
3053 See the function `funvec' for more detail. */
3054
3055Lisp_Object
3056make_funvec (kind, num_nil_slots, num_params, params)
3057 Lisp_Object kind;
3058 int num_nil_slots, num_params;
3059 Lisp_Object *params;
3060{
3061 int param_index;
3062 Lisp_Object funvec;
3063
3064 funvec = Fmake_vector (make_number (1 + num_nil_slots + num_params), Qnil);
3065
3066 ASET (funvec, 0, kind);
3067
3068 for (param_index = 0; param_index < num_params; param_index++)
3069 ASET (funvec, 1 + num_nil_slots + param_index, params[param_index]);
3070
3071 XSETPVECTYPE (XVECTOR (funvec), PVEC_FUNVEC);
3072 XSETFUNVEC (funvec, XVECTOR (funvec));
3073
3074 return funvec;
3075}
3076
3077
3045DEFUN ("vector", Fvector, Svector, 0, MANY, 0, 3078DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3046 doc: /* Return a newly created vector with specified arguments as elements. 3079 doc: /* Return a newly created vector with specified arguments as elements.
3047Any number of arguments, even zero arguments, are allowed. 3080Any number of arguments, even zero arguments, are allowed.
@@ -3063,6 +3096,29 @@ usage: (vector &rest OBJECTS) */)
3063} 3096}
3064 3097
3065 3098
3099DEFUN ("funvec", Ffunvec, Sfunvec, 1, MANY, 0,
3100 doc: /* Return a newly created `function vector' of type KIND.
3101A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp.
3102KIND indicates the kind of funvec, and determines its behavior when called.
3103The meaning of the remaining arguments depends on KIND. Currently
3104implemented values of KIND, and their meaning, are:
3105
3106 A list -- A byte-compiled function. See `make-byte-code' for the usual
3107 way to create byte-compiled functions.
3108
3109 `curry' -- A curried function. Remaining arguments are a function to
3110 call, and arguments to prepend to user arguments at the
3111 time of the call; see the `curry' function.
3112
3113usage: (funvec KIND &rest PARAMS) */)
3114 (nargs, args)
3115 register int nargs;
3116 Lisp_Object *args;
3117{
3118 return make_funvec (args[0], 0, nargs - 1, args + 1);
3119}
3120
3121
3066DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 3122DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3067 doc: /* Create a byte-code object with specified arguments as elements. 3123 doc: /* Create a byte-code object with specified arguments as elements.
3068The arguments should be the arglist, bytecode-string, constant vector, 3124The arguments should be the arglist, bytecode-string, constant vector,
@@ -3078,6 +3134,10 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3078 register int index; 3134 register int index;
3079 register struct Lisp_Vector *p; 3135 register struct Lisp_Vector *p;
3080 3136
3137 /* Make sure the arg-list is really a list, as that's what's used to
3138 distinguish a byte-compiled object from other funvecs. */
3139 CHECK_LIST (args[0]);
3140
3081 XSETFASTINT (len, nargs); 3141 XSETFASTINT (len, nargs);
3082 if (!NILP (Vpurify_flag)) 3142 if (!NILP (Vpurify_flag))
3083 val = make_pure_vector ((EMACS_INT) nargs); 3143 val = make_pure_vector ((EMACS_INT) nargs);
@@ -3099,8 +3159,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3099 args[index] = Fpurecopy (args[index]); 3159 args[index] = Fpurecopy (args[index]);
3100 p->contents[index] = args[index]; 3160 p->contents[index] = args[index];
3101 } 3161 }
3102 XSETPVECTYPE (p, PVEC_COMPILED); 3162 XSETPVECTYPE (p, PVEC_FUNVEC);
3103 XSETCOMPILED (val, p); 3163 XSETFUNVEC (val, p);
3104 return val; 3164 return val;
3105} 3165}
3106 3166
@@ -3199,6 +3259,7 @@ Its value and function definition are void, and its property list is nil. */)
3199 p->gcmarkbit = 0; 3259 p->gcmarkbit = 0;
3200 p->interned = SYMBOL_UNINTERNED; 3260 p->interned = SYMBOL_UNINTERNED;
3201 p->constant = 0; 3261 p->constant = 0;
3262 p->declared_special = 0;
3202 consing_since_gc += sizeof (struct Lisp_Symbol); 3263 consing_since_gc += sizeof (struct Lisp_Symbol);
3203 symbols_consed++; 3264 symbols_consed++;
3204 return val; 3265 return val;
@@ -4907,7 +4968,7 @@ Does not copy symbols. Copies strings without text properties. */)
4907 obj = make_pure_string (SDATA (obj), SCHARS (obj), 4968 obj = make_pure_string (SDATA (obj), SCHARS (obj),
4908 SBYTES (obj), 4969 SBYTES (obj),
4909 STRING_MULTIBYTE (obj)); 4970 STRING_MULTIBYTE (obj));
4910 else if (COMPILEDP (obj) || VECTORP (obj)) 4971 else if (FUNVECP (obj) || VECTORP (obj))
4911 { 4972 {
4912 register struct Lisp_Vector *vec; 4973 register struct Lisp_Vector *vec;
4913 register int i; 4974 register int i;
@@ -4919,10 +4980,10 @@ Does not copy symbols. Copies strings without text properties. */)
4919 vec = XVECTOR (make_pure_vector (size)); 4980 vec = XVECTOR (make_pure_vector (size));
4920 for (i = 0; i < size; i++) 4981 for (i = 0; i < size; i++)
4921 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); 4982 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
4922 if (COMPILEDP (obj)) 4983 if (FUNVECP (obj))
4923 { 4984 {
4924 XSETPVECTYPE (vec, PVEC_COMPILED); 4985 XSETPVECTYPE (vec, PVEC_FUNVEC);
4925 XSETCOMPILED (obj, vec); 4986 XSETFUNVEC (obj, vec);
4926 } 4987 }
4927 else 4988 else
4928 XSETVECTOR (obj, vec); 4989 XSETVECTOR (obj, vec);
@@ -5512,7 +5573,7 @@ mark_object (arg)
5512 } 5573 }
5513 else if (SUBRP (obj)) 5574 else if (SUBRP (obj))
5514 break; 5575 break;
5515 else if (COMPILEDP (obj)) 5576 else if (FUNVECP (obj) && FUNVEC_COMPILED_P (obj))
5516 /* We could treat this just like a vector, but it is better to 5577 /* We could treat this just like a vector, but it is better to
5517 save the COMPILED_CONSTANTS element for last and avoid 5578 save the COMPILED_CONSTANTS element for last and avoid
5518 recursion there. */ 5579 recursion there. */
@@ -6423,6 +6484,7 @@ The time is in seconds as a floating point value. */);
6423 defsubr (&Scons); 6484 defsubr (&Scons);
6424 defsubr (&Slist); 6485 defsubr (&Slist);
6425 defsubr (&Svector); 6486 defsubr (&Svector);
6487 defsubr (&Sfunvec);
6426 defsubr (&Smake_byte_code); 6488 defsubr (&Smake_byte_code);
6427 defsubr (&Smake_list); 6489 defsubr (&Smake_list);
6428 defsubr (&Smake_vector); 6490 defsubr (&Smake_vector);
diff --git a/src/buffer.c b/src/buffer.c
index 589266f40e5..e907c295e8d 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -5418,6 +5418,7 @@ defvar_per_buffer (bo_fwd, namestring, address, type, doc)
5418 bo_fwd->type = Lisp_Fwd_Buffer_Obj; 5418 bo_fwd->type = Lisp_Fwd_Buffer_Obj;
5419 bo_fwd->offset = offset; 5419 bo_fwd->offset = offset;
5420 bo_fwd->slottype = type; 5420 bo_fwd->slottype = type;
5421 sym->declared_special = 1;
5421 sym->redirect = SYMBOL_FORWARDED; 5422 sym->redirect = SYMBOL_FORWARDED;
5422 { 5423 {
5423 /* I tried to do the job without a cast, but it seems impossible. 5424 /* I tried to do the job without a cast, but it seems impossible.
diff --git a/src/bytecode.c b/src/bytecode.c
index c53c5acdbb3..fec855c0b83 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -87,9 +87,11 @@ int byte_metering_on;
87 87
88 88
89Lisp_Object Qbytecode; 89Lisp_Object Qbytecode;
90extern Lisp_Object Qand_optional, Qand_rest;
90 91
91/* Byte codes: */ 92/* Byte codes: */
92 93
94#define Bstack_ref 0
93#define Bvarref 010 95#define Bvarref 010
94#define Bvarset 020 96#define Bvarset 020
95#define Bvarbind 030 97#define Bvarbind 030
@@ -229,6 +231,13 @@ Lisp_Object Qbytecode;
229#define BconcatN 0260 231#define BconcatN 0260
230#define BinsertN 0261 232#define BinsertN 0261
231 233
234/* Bstack_ref is code 0. */
235#define Bstack_set 0262
236#define Bstack_set2 0263
237#define Bvec_ref 0264
238#define Bvec_set 0265
239#define BdiscardN 0266
240
232#define Bconstant 0300 241#define Bconstant 0300
233#define CONSTANTLIM 0100 242#define CONSTANTLIM 0100
234 243
@@ -397,14 +406,41 @@ unmark_byte_stack ()
397 } while (0) 406 } while (0)
398 407
399 408
400DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, 409DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0,
401 doc: /* Function used internally in byte-compiled code. 410 doc: /* Function used internally in byte-compiled code.
402The first argument, BYTESTR, is a string of byte code; 411The first argument, BYTESTR, is a string of byte code;
403the second, VECTOR, a vector of constants; 412the second, VECTOR, a vector of constants;
404the third, MAXDEPTH, the maximum stack depth used in this function. 413the third, MAXDEPTH, the maximum stack depth used in this function.
405If the third argument is incorrect, Emacs may crash. */) 414If the third argument is incorrect, Emacs may crash.
406 (bytestr, vector, maxdepth) 415
407 Lisp_Object bytestr, vector, maxdepth; 416If ARGS-TEMPLATE is specified, it is an argument list specification,
417according to which any remaining arguments are pushed on the stack
418before executing BYTESTR.
419
420usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */)
421 (nargs, args)
422 int nargs;
423 Lisp_Object *args;
424{
425 Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil;
426 int pnargs = nargs >= 4 ? nargs - 4 : 0;
427 Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0;
428 return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs);
429}
430
431/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
432 MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
433 emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
434 argument list (including &rest, &optional, etc.), and ARGS, of size
435 NARGS, should be a vector of the actual arguments. The arguments in
436 ARGS are pushed on the stack according to ARGS_TEMPLATE before
437 executing BYTESTR. */
438
439Lisp_Object
440exec_byte_code (bytestr, vector, maxdepth, args_template, nargs, args)
441 Lisp_Object bytestr, vector, maxdepth, args_template;
442 int nargs;
443 Lisp_Object *args;
408{ 444{
409 int count = SPECPDL_INDEX (); 445 int count = SPECPDL_INDEX ();
410#ifdef BYTE_CODE_METER 446#ifdef BYTE_CODE_METER
@@ -462,6 +498,37 @@ If the third argument is incorrect, Emacs may crash. */)
462 stacke = stack.bottom - 1 + XFASTINT (maxdepth); 498 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
463#endif 499#endif
464 500
501 if (! NILP (args_template))
502 /* We should push some arguments on the stack. */
503 {
504 Lisp_Object at;
505 int pushed = 0, optional = 0;
506
507 for (at = args_template; CONSP (at); at = XCDR (at))
508 if (EQ (XCAR (at), Qand_optional))
509 optional = 1;
510 else if (EQ (XCAR (at), Qand_rest))
511 {
512 PUSH (Flist (nargs, args));
513 pushed = nargs;
514 at = Qnil;
515 break;
516 }
517 else if (pushed < nargs)
518 {
519 PUSH (*args++);
520 pushed++;
521 }
522 else if (optional)
523 PUSH (Qnil);
524 else
525 break;
526
527 if (pushed != nargs || !NILP (at))
528 Fsignal (Qwrong_number_of_arguments,
529 Fcons (args_template, Fcons (make_number (nargs), Qnil)));
530 }
531
465 while (1) 532 while (1)
466 { 533 {
467#ifdef BYTE_CODE_SAFE 534#ifdef BYTE_CODE_SAFE
@@ -1641,8 +1708,57 @@ If the third argument is incorrect, Emacs may crash. */)
1641 break; 1708 break;
1642#endif 1709#endif
1643 1710
1644 case 0: 1711 /* Handy byte-codes for lexical binding. */
1645 abort (); 1712 case Bstack_ref:
1713 case Bstack_ref+1:
1714 case Bstack_ref+2:
1715 case Bstack_ref+3:
1716 case Bstack_ref+4:
1717 case Bstack_ref+5:
1718 PUSH (stack.bottom[op - Bstack_ref]);
1719 break;
1720 case Bstack_ref+6:
1721 PUSH (stack.bottom[FETCH]);
1722 break;
1723 case Bstack_ref+7:
1724 PUSH (stack.bottom[FETCH2]);
1725 break;
1726 case Bstack_set:
1727 stack.bottom[FETCH] = POP;
1728 break;
1729 case Bstack_set2:
1730 stack.bottom[FETCH2] = POP;
1731 break;
1732 case Bvec_ref:
1733 case Bvec_set:
1734 /* These byte-codes used mostly for variable references to
1735 lexically bound variables that are in an environment vector
1736 instead of on the byte-interpreter stack (generally those
1737 variables which might be shared with a closure). */
1738 {
1739 int index = FETCH;
1740 Lisp_Object vec = POP;
1741
1742 if (! VECTORP (vec))
1743 wrong_type_argument (Qvectorp, vec);
1744 else if (index < 0 || index >= XVECTOR (vec)->size)
1745 args_out_of_range (vec, index);
1746
1747 if (op == Bvec_ref)
1748 PUSH (XVECTOR (vec)->contents[index]);
1749 else
1750 XVECTOR (vec)->contents[index] = POP;
1751 }
1752 break;
1753 case BdiscardN:
1754 op = FETCH;
1755 if (op & 0x80)
1756 {
1757 op &= 0x7F;
1758 top[-op] = TOP;
1759 }
1760 DISCARD (op);
1761 break;
1646 1762
1647 case 255: 1763 case 255:
1648 default: 1764 default:
diff --git a/src/data.c b/src/data.c
index 93cc57e9f2c..6a21ad44720 100644
--- a/src/data.c
+++ b/src/data.c
@@ -84,7 +84,7 @@ Lisp_Object Qinteger;
84static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; 84static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
85static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; 85static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
86Lisp_Object Qprocess; 86Lisp_Object Qprocess;
87static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; 87static Lisp_Object Qcompiled_function, Qfunction_vector, Qbuffer, Qframe, Qvector;
88static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; 88static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
89static Lisp_Object Qsubrp, Qmany, Qunevalled; 89static Lisp_Object Qsubrp, Qmany, Qunevalled;
90Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; 90Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
@@ -219,8 +219,11 @@ for example, (type-of 1) returns `integer'. */)
219 return Qwindow; 219 return Qwindow;
220 if (SUBRP (object)) 220 if (SUBRP (object))
221 return Qsubr; 221 return Qsubr;
222 if (COMPILEDP (object)) 222 if (FUNVECP (object))
223 return Qcompiled_function; 223 if (FUNVEC_COMPILED_P (object))
224 return Qcompiled_function;
225 else
226 return Qfunction_vector;
224 if (BUFFERP (object)) 227 if (BUFFERP (object))
225 return Qbuffer; 228 return Qbuffer;
226 if (CHAR_TABLE_P (object)) 229 if (CHAR_TABLE_P (object))
@@ -437,6 +440,14 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
437 return Qnil; 440 return Qnil;
438} 441}
439 442
443DEFUN ("funvecp", Ffunvecp, Sfunvecp, 1, 1, 0,
444 doc: /* Return t if OBJECT is a `function vector' object. */)
445 (object)
446 Lisp_Object object;
447{
448 return FUNVECP (object) ? Qt : Qnil;
449}
450
440DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, 451DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
441 doc: /* Return t if OBJECT is a character or a string. */) 452 doc: /* Return t if OBJECT is a character or a string. */)
442 (object) 453 (object)
@@ -2208,15 +2219,15 @@ or a byte-code object. IDX starts at 0. */)
2208 { 2219 {
2209 int size = 0; 2220 int size = 0;
2210 if (VECTORP (array)) 2221 if (VECTORP (array))
2211 size = XVECTOR (array)->size; 2222 size = ASIZE (array);
2212 else if (COMPILEDP (array)) 2223 else if (FUNVECP (array))
2213 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; 2224 size = FUNVEC_SIZE (array);
2214 else 2225 else
2215 wrong_type_argument (Qarrayp, array); 2226 wrong_type_argument (Qarrayp, array);
2216 2227
2217 if (idxval < 0 || idxval >= size) 2228 if (idxval < 0 || idxval >= size)
2218 args_out_of_range (array, idx); 2229 args_out_of_range (array, idx);
2219 return XVECTOR (array)->contents[idxval]; 2230 return AREF (array, idxval);
2220 } 2231 }
2221} 2232}
2222 2233
@@ -3326,6 +3337,7 @@ syms_of_data ()
3326 Qwindow = intern_c_string ("window"); 3337 Qwindow = intern_c_string ("window");
3327 /* Qsubr = intern_c_string ("subr"); */ 3338 /* Qsubr = intern_c_string ("subr"); */
3328 Qcompiled_function = intern_c_string ("compiled-function"); 3339 Qcompiled_function = intern_c_string ("compiled-function");
3340 Qfunction_vector = intern_c_string ("function-vector");
3329 Qbuffer = intern_c_string ("buffer"); 3341 Qbuffer = intern_c_string ("buffer");
3330 Qframe = intern_c_string ("frame"); 3342 Qframe = intern_c_string ("frame");
3331 Qvector = intern_c_string ("vector"); 3343 Qvector = intern_c_string ("vector");
@@ -3351,6 +3363,7 @@ syms_of_data ()
3351 staticpro (&Qwindow); 3363 staticpro (&Qwindow);
3352 /* staticpro (&Qsubr); */ 3364 /* staticpro (&Qsubr); */
3353 staticpro (&Qcompiled_function); 3365 staticpro (&Qcompiled_function);
3366 staticpro (&Qfunction_vector);
3354 staticpro (&Qbuffer); 3367 staticpro (&Qbuffer);
3355 staticpro (&Qframe); 3368 staticpro (&Qframe);
3356 staticpro (&Qvector); 3369 staticpro (&Qvector);
@@ -3387,6 +3400,7 @@ syms_of_data ()
3387 defsubr (&Smarkerp); 3400 defsubr (&Smarkerp);
3388 defsubr (&Ssubrp); 3401 defsubr (&Ssubrp);
3389 defsubr (&Sbyte_code_function_p); 3402 defsubr (&Sbyte_code_function_p);
3403 defsubr (&Sfunvecp);
3390 defsubr (&Schar_or_string_p); 3404 defsubr (&Schar_or_string_p);
3391 defsubr (&Scar); 3405 defsubr (&Scar);
3392 defsubr (&Scdr); 3406 defsubr (&Scdr);
diff --git a/src/doc.c b/src/doc.c
index 536d22c57a6..9133c2e6b84 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -56,7 +56,7 @@ Lisp_Object Qfunction_documentation;
56/* A list of files used to build this Emacs binary. */ 56/* A list of files used to build this Emacs binary. */
57static Lisp_Object Vbuild_files; 57static Lisp_Object Vbuild_files;
58 58
59extern Lisp_Object Voverriding_local_map; 59extern Lisp_Object Voverriding_local_map, Qclosure;
60 60
61extern Lisp_Object Qremap; 61extern Lisp_Object Qremap;
62 62
@@ -385,6 +385,11 @@ string is passed through `substitute-command-keys'. */)
385 else 385 else
386 return Qnil; 386 return Qnil;
387 } 387 }
388 else if (FUNVECP (fun))
389 {
390 /* Unless otherwise handled, funvecs have no documentation. */
391 return Qnil;
392 }
388 else if (STRINGP (fun) || VECTORP (fun)) 393 else if (STRINGP (fun) || VECTORP (fun))
389 { 394 {
390 return build_string ("Keyboard macro."); 395 return build_string ("Keyboard macro.");
@@ -412,6 +417,8 @@ string is passed through `substitute-command-keys'. */)
412 else 417 else
413 return Qnil; 418 return Qnil;
414 } 419 }
420 else if (EQ (funcar, Qclosure))
421 return Fdocumentation (Fcdr (XCDR (fun)), raw);
415 else if (EQ (funcar, Qmacro)) 422 else if (EQ (funcar, Qmacro))
416 return Fdocumentation (Fcdr (fun), raw); 423 return Fdocumentation (Fcdr (fun), raw);
417 else 424 else
@@ -542,6 +549,8 @@ store_function_docstring (fun, offset)
542 } 549 }
543 else if (EQ (tem, Qmacro)) 550 else if (EQ (tem, Qmacro))
544 store_function_docstring (XCDR (fun), offset); 551 store_function_docstring (XCDR (fun), offset);
552 else if (EQ (tem, Qclosure))
553 store_function_docstring (Fcdr (XCDR (fun)), offset);
545 } 554 }
546 555
547 /* Bytecode objects sometimes have slots for it. */ 556 /* Bytecode objects sometimes have slots for it. */
diff --git a/src/eval.c b/src/eval.c
index 199c4705736..875b4498a61 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -62,6 +62,9 @@ Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
62Lisp_Object Qand_rest, Qand_optional; 62Lisp_Object Qand_rest, Qand_optional;
63Lisp_Object Qdebug_on_error; 63Lisp_Object Qdebug_on_error;
64Lisp_Object Qdeclare; 64Lisp_Object Qdeclare;
65Lisp_Object Qcurry, Qunevalled;
66Lisp_Object Qinternal_interpreter_environment, Qclosure;
67
65Lisp_Object Qdebug; 68Lisp_Object Qdebug;
66extern Lisp_Object Qinteractive_form; 69extern Lisp_Object Qinteractive_form;
67 70
@@ -78,6 +81,13 @@ Lisp_Object Vrun_hooks;
78 81
79Lisp_Object Vautoload_queue; 82Lisp_Object Vautoload_queue;
80 83
84/* When lexical binding is being used, this is non-nil, and contains an
85 alist of lexically-bound variable, or t, indicating an empty
86 environment. The lisp name of this variable is
87 `internal-interpreter-lexical-environment'. */
88
89Lisp_Object Vinternal_interpreter_environment;
90
81/* Current number of specbindings allocated in specpdl. */ 91/* Current number of specbindings allocated in specpdl. */
82 92
83int specpdl_size; 93int specpdl_size;
@@ -167,10 +177,11 @@ int handling_signal;
167Lisp_Object Vmacro_declaration_function; 177Lisp_Object Vmacro_declaration_function;
168 178
169extern Lisp_Object Qrisky_local_variable; 179extern Lisp_Object Qrisky_local_variable;
170
171extern Lisp_Object Qfunction; 180extern Lisp_Object Qfunction;
172 181
173static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object*)); 182static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object *,
183 Lisp_Object));
184
174static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN; 185static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN;
175 186
176#if __GNUC__ 187#if __GNUC__
@@ -504,7 +515,7 @@ usage: (setq [SYM VAL]...) */)
504 Lisp_Object args; 515 Lisp_Object args;
505{ 516{
506 register Lisp_Object args_left; 517 register Lisp_Object args_left;
507 register Lisp_Object val, sym; 518 register Lisp_Object val, sym, lex_binding;
508 struct gcpro gcpro1; 519 struct gcpro gcpro1;
509 520
510 if (NILP (args)) 521 if (NILP (args))
@@ -517,7 +528,15 @@ usage: (setq [SYM VAL]...) */)
517 { 528 {
518 val = Feval (Fcar (Fcdr (args_left))); 529 val = Feval (Fcar (Fcdr (args_left)));
519 sym = Fcar (args_left); 530 sym = Fcar (args_left);
520 Fset (sym, val); 531
532 if (!NILP (Vinternal_interpreter_environment)
533 && SYMBOLP (sym)
534 && !XSYMBOL (sym)->declared_special
535 && !NILP (lex_binding = Fassq (sym, Vinternal_interpreter_environment)))
536 XSETCDR (lex_binding, val); /* SYM is lexically bound. */
537 else
538 Fset (sym, val); /* SYM is dynamically bound. */
539
521 args_left = Fcdr (Fcdr (args_left)); 540 args_left = Fcdr (Fcdr (args_left));
522 } 541 }
523 while (!NILP(args_left)); 542 while (!NILP(args_left));
@@ -545,9 +564,20 @@ usage: (function ARG) */)
545 (args) 564 (args)
546 Lisp_Object args; 565 Lisp_Object args;
547{ 566{
567 Lisp_Object quoted = XCAR (args);
568
548 if (!NILP (Fcdr (args))) 569 if (!NILP (Fcdr (args)))
549 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); 570 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
550 return Fcar (args); 571
572 if (!NILP (Vinternal_interpreter_environment)
573 && CONSP (quoted)
574 && EQ (XCAR (quoted), Qlambda))
575 /* This is a lambda expression within a lexical environment;
576 return an interpreted closure instead of a simple lambda. */
577 return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, quoted));
578 else
579 /* Simply quote the argument. */
580 return quoted;
551} 581}
552 582
553 583
@@ -570,7 +600,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
570use `called-interactively-p'. */) 600use `called-interactively-p'. */)
571 () 601 ()
572{ 602{
573 return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; 603 return interactive_p (1) ? Qt : Qnil;
574} 604}
575 605
576 606
@@ -666,6 +696,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
666 fn_name = Fcar (args); 696 fn_name = Fcar (args);
667 CHECK_SYMBOL (fn_name); 697 CHECK_SYMBOL (fn_name);
668 defn = Fcons (Qlambda, Fcdr (args)); 698 defn = Fcons (Qlambda, Fcdr (args));
699 if (! NILP (Vinternal_interpreter_environment))
700 defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn));
669 if (!NILP (Vpurify_flag)) 701 if (!NILP (Vpurify_flag))
670 defn = Fpurecopy (defn); 702 defn = Fpurecopy (defn);
671 if (CONSP (XSYMBOL (fn_name)->function) 703 if (CONSP (XSYMBOL (fn_name)->function)
@@ -738,7 +770,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
738 tail = Fcons (lambda_list, tail); 770 tail = Fcons (lambda_list, tail);
739 else 771 else
740 tail = Fcons (lambda_list, Fcons (doc, tail)); 772 tail = Fcons (lambda_list, Fcons (doc, tail));
741 defn = Fcons (Qmacro, Fcons (Qlambda, tail)); 773
774 defn = Fcons (Qlambda, tail);
775 if (! NILP (Vinternal_interpreter_environment))
776 defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn));
777 defn = Fcons (Qmacro, defn);
742 778
743 if (!NILP (Vpurify_flag)) 779 if (!NILP (Vpurify_flag))
744 defn = Fpurecopy (defn); 780 defn = Fpurecopy (defn);
@@ -799,6 +835,7 @@ The return value is BASE-VARIABLE. */)
799 error ("Don't know how to make a let-bound variable an alias"); 835 error ("Don't know how to make a let-bound variable an alias");
800 } 836 }
801 837
838 sym->declared_special = 1;
802 sym->redirect = SYMBOL_VARALIAS; 839 sym->redirect = SYMBOL_VARALIAS;
803 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); 840 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
804 sym->constant = SYMBOL_CONSTANT_P (base_variable); 841 sym->constant = SYMBOL_CONSTANT_P (base_variable);
@@ -889,6 +926,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
889 It could get in the way of other definitions, and unloading this 926 It could get in the way of other definitions, and unloading this
890 package could try to make the variable unbound. */ 927 package could try to make the variable unbound. */
891 ; 928 ;
929
930 if (SYMBOLP (sym))
931 XSYMBOL (sym)->declared_special = 1;
892 932
893 return sym; 933 return sym;
894} 934}
@@ -918,6 +958,7 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
918 if (!NILP (Vpurify_flag)) 958 if (!NILP (Vpurify_flag))
919 tem = Fpurecopy (tem); 959 tem = Fpurecopy (tem);
920 Fset_default (sym, tem); 960 Fset_default (sym, tem);
961 XSYMBOL (sym)->declared_special = 1;
921 tem = Fcar (Fcdr (Fcdr (args))); 962 tem = Fcar (Fcdr (Fcdr (args)));
922 if (!NILP (tem)) 963 if (!NILP (tem))
923 { 964 {
@@ -1006,30 +1047,50 @@ usage: (let* VARLIST BODY...) */)
1006 (args) 1047 (args)
1007 Lisp_Object args; 1048 Lisp_Object args;
1008{ 1049{
1009 Lisp_Object varlist, val, elt; 1050 Lisp_Object varlist, var, val, elt, lexenv;
1010 int count = SPECPDL_INDEX (); 1051 int count = SPECPDL_INDEX ();
1011 struct gcpro gcpro1, gcpro2, gcpro3; 1052 struct gcpro gcpro1, gcpro2, gcpro3;
1012 1053
1013 GCPRO3 (args, elt, varlist); 1054 GCPRO3 (args, elt, varlist);
1014 1055
1056 lexenv = Vinternal_interpreter_environment;
1057
1015 varlist = Fcar (args); 1058 varlist = Fcar (args);
1016 while (!NILP (varlist)) 1059 while (CONSP (varlist))
1017 { 1060 {
1018 QUIT; 1061 QUIT;
1019 elt = Fcar (varlist); 1062
1063 elt = XCAR (varlist);
1020 if (SYMBOLP (elt)) 1064 if (SYMBOLP (elt))
1021 specbind (elt, Qnil); 1065 {
1066 var = elt;
1067 val = Qnil;
1068 }
1022 else if (! NILP (Fcdr (Fcdr (elt)))) 1069 else if (! NILP (Fcdr (Fcdr (elt))))
1023 signal_error ("`let' bindings can have only one value-form", elt); 1070 signal_error ("`let' bindings can have only one value-form", elt);
1024 else 1071 else
1025 { 1072 {
1073 var = Fcar (elt);
1026 val = Feval (Fcar (Fcdr (elt))); 1074 val = Feval (Fcar (Fcdr (elt)));
1027 specbind (Fcar (elt), val);
1028 } 1075 }
1029 varlist = Fcdr (varlist); 1076
1077 if (!NILP (lexenv) && SYMBOLP (var) && !XSYMBOL (var)->declared_special)
1078 /* Lexically bind VAR by adding it to the interpreter's binding
1079 alist. */
1080 {
1081 lexenv = Fcons (Fcons (var, val), lexenv);
1082 specbind (Qinternal_interpreter_environment, lexenv);
1083 }
1084 else
1085 specbind (var, val);
1086
1087 varlist = XCDR (varlist);
1030 } 1088 }
1089
1031 UNGCPRO; 1090 UNGCPRO;
1091
1032 val = Fprogn (Fcdr (args)); 1092 val = Fprogn (Fcdr (args));
1093
1033 return unbind_to (count, val); 1094 return unbind_to (count, val);
1034} 1095}
1035 1096
@@ -1043,7 +1104,7 @@ usage: (let VARLIST BODY...) */)
1043 (args) 1104 (args)
1044 Lisp_Object args; 1105 Lisp_Object args;
1045{ 1106{
1046 Lisp_Object *temps, tem; 1107 Lisp_Object *temps, tem, lexenv;
1047 register Lisp_Object elt, varlist; 1108 register Lisp_Object elt, varlist;
1048 int count = SPECPDL_INDEX (); 1109 int count = SPECPDL_INDEX ();
1049 register int argnum; 1110 register int argnum;
@@ -1074,18 +1135,31 @@ usage: (let VARLIST BODY...) */)
1074 } 1135 }
1075 UNGCPRO; 1136 UNGCPRO;
1076 1137
1138 lexenv = Vinternal_interpreter_environment;
1139
1077 varlist = Fcar (args); 1140 varlist = Fcar (args);
1078 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) 1141 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
1079 { 1142 {
1143 Lisp_Object var;
1144
1080 elt = XCAR (varlist); 1145 elt = XCAR (varlist);
1146 var = SYMBOLP (elt) ? elt : Fcar (elt);
1081 tem = temps[argnum++]; 1147 tem = temps[argnum++];
1082 if (SYMBOLP (elt)) 1148
1083 specbind (elt, tem); 1149 if (!NILP (lexenv) && SYMBOLP (var) && !XSYMBOL (var)->declared_special)
1150 /* Lexically bind VAR by adding it to the lexenv alist. */
1151 lexenv = Fcons (Fcons (var, tem), lexenv);
1084 else 1152 else
1085 specbind (Fcar (elt), tem); 1153 /* Dynamically bind VAR. */
1154 specbind (var, tem);
1086 } 1155 }
1087 1156
1157 if (!EQ (lexenv, Vinternal_interpreter_environment))
1158 /* Instantiate a new lexical environment. */
1159 specbind (Qinternal_interpreter_environment, lexenv);
1160
1088 elt = Fprogn (Fcdr (args)); 1161 elt = Fprogn (Fcdr (args));
1162
1089 return unbind_to (count, elt); 1163 return unbind_to (count, elt);
1090} 1164}
1091 1165
@@ -2292,7 +2366,28 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2292 abort (); 2366 abort ();
2293 2367
2294 if (SYMBOLP (form)) 2368 if (SYMBOLP (form))
2295 return Fsymbol_value (form); 2369 {
2370 /* If there's an active lexical environment, and the variable
2371 isn't declared special, look up its binding in the lexical
2372 environment. */
2373 if (!NILP (Vinternal_interpreter_environment)
2374 && !XSYMBOL (form)->declared_special)
2375 {
2376 Lisp_Object lex_binding
2377 = Fassq (form, Vinternal_interpreter_environment);
2378
2379 /* If we found a lexical binding for FORM, return the value.
2380 Otherwise, we just drop through and look for a dynamic
2381 binding -- the variable isn't declared special, but there's
2382 not much else we can do, and Fsymbol_value will take care
2383 of signaling an error if there is no binding at all. */
2384 if (CONSP (lex_binding))
2385 return XCDR (lex_binding);
2386 }
2387
2388 return Fsymbol_value (form);
2389 }
2390
2296 if (!CONSP (form)) 2391 if (!CONSP (form))
2297 return form; 2392 return form;
2298 2393
@@ -2452,8 +2547,8 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2452 abort (); 2547 abort ();
2453 } 2548 }
2454 } 2549 }
2455 if (COMPILEDP (fun)) 2550 if (FUNVECP (fun))
2456 val = apply_lambda (fun, original_args, 1); 2551 val = apply_lambda (fun, original_args, 1, Qnil);
2457 else 2552 else
2458 { 2553 {
2459 if (EQ (fun, Qunbound)) 2554 if (EQ (fun, Qunbound))
@@ -2471,7 +2566,18 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2471 if (EQ (funcar, Qmacro)) 2566 if (EQ (funcar, Qmacro))
2472 val = Feval (apply1 (Fcdr (fun), original_args)); 2567 val = Feval (apply1 (Fcdr (fun), original_args));
2473 else if (EQ (funcar, Qlambda)) 2568 else if (EQ (funcar, Qlambda))
2474 val = apply_lambda (fun, original_args, 1); 2569 val = apply_lambda (fun, original_args, 1,
2570 /* Only pass down the current lexical environment
2571 if FUN is lexically embedded in FORM. */
2572 (CONSP (original_fun)
2573 ? Vinternal_interpreter_environment
2574 : Qnil));
2575 else if (EQ (funcar, Qclosure)
2576 && CONSP (XCDR (fun))
2577 && CONSP (XCDR (XCDR (fun)))
2578 && EQ (XCAR (XCDR (XCDR (fun))), Qlambda))
2579 val = apply_lambda (XCDR (XCDR (fun)), original_args, 1,
2580 XCAR (XCDR (fun)));
2475 else 2581 else
2476 xsignal1 (Qinvalid_function, original_fun); 2582 xsignal1 (Qinvalid_function, original_fun);
2477 } 2583 }
@@ -2981,6 +3087,40 @@ call7 (fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7)
2981 3087
2982/* The caller should GCPRO all the elements of ARGS. */ 3088/* The caller should GCPRO all the elements of ARGS. */
2983 3089
3090DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
3091 doc: /* Return non-nil if OBJECT is a type of object that can be called as a function. */)
3092 (object)
3093 Lisp_Object object;
3094{
3095 if (SYMBOLP (object) && !NILP (Ffboundp (object)))
3096 {
3097 object = Findirect_function (object, Qnil);
3098
3099 if (CONSP (object) && EQ (XCAR (object), Qautoload))
3100 {
3101 /* Autoloaded symbols are functions, except if they load
3102 macros or keymaps. */
3103 int i;
3104 for (i = 0; i < 4 && CONSP (object); i++)
3105 object = XCDR (object);
3106
3107 return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt;
3108 }
3109 }
3110
3111 if (SUBRP (object))
3112 return (XSUBR (object)->max_args != Qunevalled) ? Qt : Qnil;
3113 else if (FUNVECP (object))
3114 return Qt;
3115 else if (CONSP (object))
3116 {
3117 Lisp_Object car = XCAR (object);
3118 return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil;
3119 }
3120 else
3121 return Qnil;
3122}
3123
2984DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, 3124DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
2985 doc: /* Call first argument as a function, passing remaining arguments to it. 3125 doc: /* Call first argument as a function, passing remaining arguments to it.
2986Return the value that function returns. 3126Return the value that function returns.
@@ -3115,8 +3255,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
3115 abort (); 3255 abort ();
3116 } 3256 }
3117 } 3257 }
3118 if (COMPILEDP (fun)) 3258
3119 val = funcall_lambda (fun, numargs, args + 1); 3259 if (FUNVECP (fun))
3260 val = funcall_lambda (fun, numargs, args + 1, Qnil);
3120 else 3261 else
3121 { 3262 {
3122 if (EQ (fun, Qunbound)) 3263 if (EQ (fun, Qunbound))
@@ -3127,7 +3268,13 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
3127 if (!SYMBOLP (funcar)) 3268 if (!SYMBOLP (funcar))
3128 xsignal1 (Qinvalid_function, original_fun); 3269 xsignal1 (Qinvalid_function, original_fun);
3129 if (EQ (funcar, Qlambda)) 3270 if (EQ (funcar, Qlambda))
3130 val = funcall_lambda (fun, numargs, args + 1); 3271 val = funcall_lambda (fun, numargs, args + 1, Qnil);
3272 else if (EQ (funcar, Qclosure)
3273 && CONSP (XCDR (fun))
3274 && CONSP (XCDR (XCDR (fun)))
3275 && EQ (XCAR (XCDR (XCDR (fun))), Qlambda))
3276 val = funcall_lambda (XCDR (XCDR (fun)), numargs, args + 1,
3277 XCAR (XCDR (fun)));
3131 else if (EQ (funcar, Qautoload)) 3278 else if (EQ (funcar, Qautoload))
3132 { 3279 {
3133 do_autoload (fun, original_fun); 3280 do_autoload (fun, original_fun);
@@ -3147,9 +3294,10 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
3147} 3294}
3148 3295
3149Lisp_Object 3296Lisp_Object
3150apply_lambda (fun, args, eval_flag) 3297apply_lambda (fun, args, eval_flag, lexenv)
3151 Lisp_Object fun, args; 3298 Lisp_Object fun, args;
3152 int eval_flag; 3299 int eval_flag;
3300 Lisp_Object lexenv;
3153{ 3301{
3154 Lisp_Object args_left; 3302 Lisp_Object args_left;
3155 Lisp_Object numargs; 3303 Lisp_Object numargs;
@@ -3181,7 +3329,7 @@ apply_lambda (fun, args, eval_flag)
3181 backtrace_list->nargs = i; 3329 backtrace_list->nargs = i;
3182 } 3330 }
3183 backtrace_list->evalargs = 0; 3331 backtrace_list->evalargs = 0;
3184 tem = funcall_lambda (fun, XINT (numargs), arg_vector); 3332 tem = funcall_lambda (fun, XINT (numargs), arg_vector, lexenv);
3185 3333
3186 /* Do the debug-on-exit now, while arg_vector still exists. */ 3334 /* Do the debug-on-exit now, while arg_vector still exists. */
3187 if (backtrace_list->debug_on_exit) 3335 if (backtrace_list->debug_on_exit)
@@ -3191,20 +3339,100 @@ apply_lambda (fun, args, eval_flag)
3191 return tem; 3339 return tem;
3192} 3340}
3193 3341
3342
3343/* Call a non-bytecode funvec object FUN, on the argments in ARGS (of
3344 length NARGS). */
3345
3346static Lisp_Object
3347funcall_funvec (fun, nargs, args)
3348 Lisp_Object fun;
3349 int nargs;
3350 Lisp_Object *args;
3351{
3352 int size = FUNVEC_SIZE (fun);
3353 Lisp_Object tag = (size > 0 ? AREF (fun, 0) : Qnil);
3354
3355 if (EQ (tag, Qcurry))
3356 {
3357 /* A curried function is a way to attach arguments to a another
3358 function. The first element of the vector is the identifier
3359 `curry', the second is the wrapped function, and remaining
3360 elements are the attached arguments. */
3361 int num_curried_args = size - 2;
3362 /* Offset of the curried and user args in the final arglist. Curried
3363 args are first in the new arg vector, after the function. User
3364 args follow. */
3365 int curried_args_offs = 1;
3366 int user_args_offs = curried_args_offs + num_curried_args;
3367 /* The curried function and arguments. */
3368 Lisp_Object *curry_params = XVECTOR (fun)->contents + 1;
3369 /* The arguments in the curry vector. */
3370 Lisp_Object *curried_args = curry_params + 1;
3371 /* The number of arguments with which we'll call funcall, and the
3372 arguments themselves. */
3373 int num_funcall_args = 1 + num_curried_args + nargs;
3374 Lisp_Object *funcall_args
3375 = (Lisp_Object *) alloca (num_funcall_args * sizeof (Lisp_Object));
3376
3377 /* First comes the real function. */
3378 funcall_args[0] = curry_params[0];
3379
3380 /* Then the arguments in the appropriate order. */
3381 bcopy (curried_args, funcall_args + curried_args_offs,
3382 num_curried_args * sizeof (Lisp_Object));
3383 bcopy (args, funcall_args + user_args_offs,
3384 nargs * sizeof (Lisp_Object));
3385
3386 return Ffuncall (num_funcall_args, funcall_args);
3387 }
3388 else
3389 xsignal1 (Qinvalid_function, fun);
3390}
3391
3392
3194/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR 3393/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3195 and return the result of evaluation. 3394 and return the result of evaluation.
3196 FUN must be either a lambda-expression or a compiled-code object. */ 3395 FUN must be either a lambda-expression or a compiled-code object. */
3197 3396
3198static Lisp_Object 3397static Lisp_Object
3199funcall_lambda (fun, nargs, arg_vector) 3398funcall_lambda (fun, nargs, arg_vector, lexenv)
3200 Lisp_Object fun; 3399 Lisp_Object fun;
3201 int nargs; 3400 int nargs;
3202 register Lisp_Object *arg_vector; 3401 register Lisp_Object *arg_vector;
3402 Lisp_Object lexenv;
3203{ 3403{
3204 Lisp_Object val, syms_left, next; 3404 Lisp_Object val, syms_left, next;
3205 int count = SPECPDL_INDEX (); 3405 int count = SPECPDL_INDEX ();
3206 int i, optional, rest; 3406 int i, optional, rest;
3207 3407
3408 if (COMPILEDP (fun)
3409 && FUNVEC_SIZE (fun) > COMPILED_PUSH_ARGS
3410 && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS]))
3411 /* A byte-code object with a non-nil `push args' slot means we
3412 shouldn't bind any arguments, instead just call the byte-code
3413 interpreter directly; it will push arguments as necessary.
3414
3415 Byte-code objects with either a non-existant, or a nil value for
3416 the `push args' slot (the default), have dynamically-bound
3417 arguments, and use the argument-binding code below instead (as do
3418 all interpreted functions, even lexically bound ones). */
3419 {
3420 /* If we have not actually read the bytecode string
3421 and constants vector yet, fetch them from the file. */
3422 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3423 Ffetch_bytecode (fun);
3424 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3425 AREF (fun, COMPILED_CONSTANTS),
3426 AREF (fun, COMPILED_STACK_DEPTH),
3427 AREF (fun, COMPILED_ARGLIST),
3428 nargs, arg_vector);
3429 }
3430
3431 if (FUNVECP (fun) && !FUNVEC_COMPILED_P (fun))
3432 /* Byte-compiled functions are handled directly below, but we
3433 call other funvec types via funcall_funvec. */
3434 return funcall_funvec (fun, nargs, arg_vector);
3435
3208 if (CONSP (fun)) 3436 if (CONSP (fun))
3209 { 3437 {
3210 syms_left = XCDR (fun); 3438 syms_left = XCDR (fun);
@@ -3236,12 +3464,27 @@ funcall_lambda (fun, nargs, arg_vector)
3236 specbind (next, Flist (nargs - i, &arg_vector[i])); 3464 specbind (next, Flist (nargs - i, &arg_vector[i]));
3237 i = nargs; 3465 i = nargs;
3238 } 3466 }
3239 else if (i < nargs)
3240 specbind (next, arg_vector[i++]);
3241 else if (!optional)
3242 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3243 else 3467 else
3244 specbind (next, Qnil); 3468 {
3469 Lisp_Object val;
3470
3471 /* Get the argument's actual value. */
3472 if (i < nargs)
3473 val = arg_vector[i++];
3474 else if (!optional)
3475 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3476 else
3477 val = Qnil;
3478
3479 /* Bind the argument. */
3480 if (!NILP (lexenv)
3481 && SYMBOLP (next) && !XSYMBOL (next)->declared_special)
3482 /* Lexically bind NEXT by adding it to the lexenv alist. */
3483 lexenv = Fcons (Fcons (next, val), lexenv);
3484 else
3485 /* Dynamically bind NEXT. */
3486 specbind (next, val);
3487 }
3245 } 3488 }
3246 3489
3247 if (!NILP (syms_left)) 3490 if (!NILP (syms_left))
@@ -3249,6 +3492,10 @@ funcall_lambda (fun, nargs, arg_vector)
3249 else if (i < nargs) 3492 else if (i < nargs)
3250 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); 3493 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3251 3494
3495 if (!EQ (lexenv, Vinternal_interpreter_environment))
3496 /* Instantiate a new lexical environment. */
3497 specbind (Qinternal_interpreter_environment, lexenv);
3498
3252 if (CONSP (fun)) 3499 if (CONSP (fun))
3253 val = Fprogn (XCDR (XCDR (fun))); 3500 val = Fprogn (XCDR (XCDR (fun)));
3254 else 3501 else
@@ -3257,9 +3504,10 @@ funcall_lambda (fun, nargs, arg_vector)
3257 and constants vector yet, fetch them from the file. */ 3504 and constants vector yet, fetch them from the file. */
3258 if (CONSP (AREF (fun, COMPILED_BYTECODE))) 3505 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3259 Ffetch_bytecode (fun); 3506 Ffetch_bytecode (fun);
3260 val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), 3507 val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3261 AREF (fun, COMPILED_CONSTANTS), 3508 AREF (fun, COMPILED_CONSTANTS),
3262 AREF (fun, COMPILED_STACK_DEPTH)); 3509 AREF (fun, COMPILED_STACK_DEPTH),
3510 Qnil, 0, 0);
3263 } 3511 }
3264 3512
3265 return unbind_to (count, val); 3513 return unbind_to (count, val);
@@ -3502,7 +3750,42 @@ unbind_to (count, value)
3502 UNGCPRO; 3750 UNGCPRO;
3503 return value; 3751 return value;
3504} 3752}
3753
3505 3754
3755
3756DEFUN ("specialp", Fspecialp, Sspecialp, 1, 1, 0,
3757 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3758A special variable is one that will be bound dynamically, even in a
3759context where binding is lexical by default. */)
3760 (symbol)
3761 Lisp_Object symbol;
3762{
3763 CHECK_SYMBOL (symbol);
3764 return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
3765}
3766
3767
3768
3769DEFUN ("curry", Fcurry, Scurry, 1, MANY, 0,
3770 doc: /* Return FUN curried with ARGS.
3771The result is a function-like object that will append any arguments it
3772is called with to ARGS, and call FUN with the resulting list of arguments.
3773
3774For instance:
3775 (funcall (curry '+ 3 4 5) 2) is the same as (funcall '+ 3 4 5 2)
3776and:
3777 (mapcar (curry 'concat "The ") '("a" "b" "c"))
3778 => ("The a" "The b" "The c")
3779
3780usage: (curry FUN &rest ARGS) */)
3781 (nargs, args)
3782 register int nargs;
3783 Lisp_Object *args;
3784{
3785 return make_funvec (Qcurry, 0, nargs, args);
3786}
3787
3788
3506DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, 3789DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3507 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. 3790 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3508The debugger is entered when that frame exits, if the flag is non-nil. */) 3791The debugger is entered when that frame exits, if the flag is non-nil. */)
@@ -3713,6 +3996,15 @@ before making `inhibit-quit' nil. */);
3713 Qand_optional = intern_c_string ("&optional"); 3996 Qand_optional = intern_c_string ("&optional");
3714 staticpro (&Qand_optional); 3997 staticpro (&Qand_optional);
3715 3998
3999 Qclosure = intern_c_string ("closure");
4000 staticpro (&Qclosure);
4001
4002 Qcurry = intern_c_string ("curry");
4003 staticpro (&Qcurry);
4004
4005 Qunevalled = intern_c_string ("unevalled");
4006 staticpro (&Qunevalled);
4007
3716 Qdebug = intern_c_string ("debug"); 4008 Qdebug = intern_c_string ("debug");
3717 staticpro (&Qdebug); 4009 staticpro (&Qdebug);
3718 4010
@@ -3788,6 +4080,17 @@ DECL is a list `(declare ...)' containing the declarations.
3788The value the function returns is not used. */); 4080The value the function returns is not used. */);
3789 Vmacro_declaration_function = Qnil; 4081 Vmacro_declaration_function = Qnil;
3790 4082
4083 Qinternal_interpreter_environment
4084 = intern_c_string ("internal-interpreter-environment");
4085 staticpro (&Qinternal_interpreter_environment);
4086 DEFVAR_LISP ("internal-interpreter-environment",
4087 &Vinternal_interpreter_environment,
4088 doc: /* If non-nil, the current lexical environment of the lisp interpreter.
4089When lexical binding is not being used, this variable is nil.
4090A value of `(t)' indicates an empty environment, otherwise it is an
4091alist of active lexical bindings. */);
4092 Vinternal_interpreter_environment = Qnil;
4093
3791 Vrun_hooks = intern_c_string ("run-hooks"); 4094 Vrun_hooks = intern_c_string ("run-hooks");
3792 staticpro (&Vrun_hooks); 4095 staticpro (&Vrun_hooks);
3793 4096
@@ -3833,9 +4136,13 @@ The value the function returns is not used. */);
3833 defsubr (&Srun_hook_with_args_until_success); 4136 defsubr (&Srun_hook_with_args_until_success);
3834 defsubr (&Srun_hook_with_args_until_failure); 4137 defsubr (&Srun_hook_with_args_until_failure);
3835 defsubr (&Sfetch_bytecode); 4138 defsubr (&Sfetch_bytecode);
4139 defsubr (&Scurry);
3836 defsubr (&Sbacktrace_debug); 4140 defsubr (&Sbacktrace_debug);
3837 defsubr (&Sbacktrace); 4141 defsubr (&Sbacktrace);
3838 defsubr (&Sbacktrace_frame); 4142 defsubr (&Sbacktrace_frame);
4143 defsubr (&Scurry);
4144 defsubr (&Sspecialp);
4145 defsubr (&Sfunctionp);
3839} 4146}
3840 4147
3841/* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb 4148/* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
diff --git a/src/fns.c b/src/fns.c
index 3f984905d1e..9569c214268 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -149,8 +149,8 @@ To get the number of bytes, use `string-bytes'. */)
149 XSETFASTINT (val, MAX_CHAR); 149 XSETFASTINT (val, MAX_CHAR);
150 else if (BOOL_VECTOR_P (sequence)) 150 else if (BOOL_VECTOR_P (sequence))
151 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); 151 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
152 else if (COMPILEDP (sequence)) 152 else if (FUNVECP (sequence))
153 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); 153 XSETFASTINT (val, FUNVEC_SIZE (sequence));
154 else if (CONSP (sequence)) 154 else if (CONSP (sequence))
155 { 155 {
156 i = 0; 156 i = 0;
@@ -535,7 +535,7 @@ concat (nargs, args, target_type, last_special)
535 { 535 {
536 this = args[argnum]; 536 this = args[argnum];
537 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) 537 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
538 || COMPILEDP (this) || BOOL_VECTOR_P (this))) 538 || FUNVECP (this) || BOOL_VECTOR_P (this)))
539 wrong_type_argument (Qsequencep, this); 539 wrong_type_argument (Qsequencep, this);
540 } 540 }
541 541
@@ -559,7 +559,7 @@ concat (nargs, args, target_type, last_special)
559 Lisp_Object ch; 559 Lisp_Object ch;
560 int this_len_byte; 560 int this_len_byte;
561 561
562 if (VECTORP (this)) 562 if (VECTORP (this) || FUNVECP (this))
563 for (i = 0; i < len; i++) 563 for (i = 0; i < len; i++)
564 { 564 {
565 ch = AREF (this, i); 565 ch = AREF (this, i);
@@ -1383,7 +1383,9 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0,
1383 return Fcar (Fnthcdr (n, sequence)); 1383 return Fcar (Fnthcdr (n, sequence));
1384 1384
1385 /* Faref signals a "not array" error, so check here. */ 1385 /* Faref signals a "not array" error, so check here. */
1386 CHECK_ARRAY (sequence, Qsequencep); 1386 if (! FUNVECP (sequence))
1387 CHECK_ARRAY (sequence, Qsequencep);
1388
1387 return Faref (sequence, n); 1389 return Faref (sequence, n);
1388} 1390}
1389 1391
@@ -2199,13 +2201,14 @@ internal_equal (o1, o2, depth, props)
2199 if (WINDOW_CONFIGURATIONP (o1)) 2201 if (WINDOW_CONFIGURATIONP (o1))
2200 return compare_window_configurations (o1, o2, 0); 2202 return compare_window_configurations (o1, o2, 0);
2201 2203
2202 /* Aside from them, only true vectors, char-tables, compiled 2204 /* Aside from them, only true vectors, char-tables, function vectors,
2203 functions, and fonts (font-spec, font-entity, font-ojbect) 2205 and fonts (font-spec, font-entity, font-ojbect) are sensible to
2204 are sensible to compare, so eliminate the others now. */ 2206 compare, so eliminate the others now. */
2205 if (size & PSEUDOVECTOR_FLAG) 2207 if (size & PSEUDOVECTOR_FLAG)
2206 { 2208 {
2207 if (!(size & (PVEC_COMPILED 2209 if (!(size & (PVEC_FUNVEC
2208 | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT))) 2210 | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE
2211 | PVEC_FONT)))
2209 return 0; 2212 return 0;
2210 size &= PSEUDOVECTOR_SIZE_MASK; 2213 size &= PSEUDOVECTOR_SIZE_MASK;
2211 } 2214 }
@@ -2416,7 +2419,7 @@ mapcar1 (leni, vals, fn, seq)
2416 1) lists are not relocated and 2) the list is marked via `seq' so will not 2419 1) lists are not relocated and 2) the list is marked via `seq' so will not
2417 be freed */ 2420 be freed */
2418 2421
2419 if (VECTORP (seq)) 2422 if (VECTORP (seq) || FUNVECP (seq))
2420 { 2423 {
2421 for (i = 0; i < leni; i++) 2424 for (i = 0; i < leni; i++)
2422 { 2425 {
diff --git a/src/image.c b/src/image.c
index b9620e10948..67c228cbc7f 100644
--- a/src/image.c
+++ b/src/image.c
@@ -885,7 +885,7 @@ parse_image_spec (spec, keywords, nkeywords, type)
885 case IMAGE_FUNCTION_VALUE: 885 case IMAGE_FUNCTION_VALUE:
886 value = indirect_function (value); 886 value = indirect_function (value);
887 if (SUBRP (value) 887 if (SUBRP (value)
888 || COMPILEDP (value) 888 || FUNVECP (value)
889 || (CONSP (value) && EQ (XCAR (value), Qlambda))) 889 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
890 break; 890 break;
891 return 0; 891 return 0;
diff --git a/src/keyboard.c b/src/keyboard.c
index 63372d600e3..18d75f9b01c 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -10390,7 +10390,7 @@ a special event, so ignore the prefix argument and don't clear it. */)
10390 return Fexecute_kbd_macro (final, prefixarg, Qnil); 10390 return Fexecute_kbd_macro (final, prefixarg, Qnil);
10391 } 10391 }
10392 10392
10393 if (CONSP (final) || SUBRP (final) || COMPILEDP (final)) 10393 if (CONSP (final) || SUBRP (final) || FUNVECP (final))
10394 /* Don't call Fcall_interactively directly because we want to make 10394 /* Don't call Fcall_interactively directly because we want to make
10395 sure the backtrace has an entry for `call-interactively'. 10395 sure the backtrace has an entry for `call-interactively'.
10396 For the same reason, pass `cmd' rather than `final'. */ 10396 For the same reason, pass `cmd' rather than `final'. */
diff --git a/src/lisp.h b/src/lisp.h
index 1941a2471a4..c7e8ea0fb8b 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -344,7 +344,7 @@ enum pvec_type
344 PVEC_NORMAL_VECTOR = 0, 344 PVEC_NORMAL_VECTOR = 0,
345 PVEC_PROCESS = 0x200, 345 PVEC_PROCESS = 0x200,
346 PVEC_FRAME = 0x400, 346 PVEC_FRAME = 0x400,
347 PVEC_COMPILED = 0x800, 347 PVEC_FUNVEC = 0x800,
348 PVEC_WINDOW = 0x1000, 348 PVEC_WINDOW = 0x1000,
349 PVEC_WINDOW_CONFIGURATION = 0x2000, 349 PVEC_WINDOW_CONFIGURATION = 0x2000,
350 PVEC_SUBR = 0x4000, 350 PVEC_SUBR = 0x4000,
@@ -623,7 +623,7 @@ extern size_t pure_size;
623#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) 623#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
624#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) 624#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
625#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) 625#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
626#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) 626#define XSETFUNVEC(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FUNVEC))
627#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) 627#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
628#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) 628#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
629#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) 629#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
@@ -639,6 +639,9 @@ extern size_t pure_size;
639 eassert ((IDX) >= 0 && (IDX) < ASIZE (ARRAY)), \ 639 eassert ((IDX) >= 0 && (IDX) < ASIZE (ARRAY)), \
640 AREF ((ARRAY), (IDX)) = (VAL)) 640 AREF ((ARRAY), (IDX)) = (VAL))
641 641
642/* Return the size of the psuedo-vector object FUNVEC. */
643#define FUNVEC_SIZE(funvec) (ASIZE (funvec) & PSEUDOVECTOR_SIZE_MASK)
644
642/* Convenience macros for dealing with Lisp strings. */ 645/* Convenience macros for dealing with Lisp strings. */
643 646
644#define SDATA(string) (XSTRING (string)->data + 0) 647#define SDATA(string) (XSTRING (string)->data + 0)
@@ -1020,6 +1023,10 @@ struct Lisp_Symbol
1020 /* Interned state of the symbol. This is an enumerator from 1023 /* Interned state of the symbol. This is an enumerator from
1021 enum symbol_interned. */ 1024 enum symbol_interned. */
1022 unsigned interned : 2; 1025 unsigned interned : 2;
1026
1027 /* Non-zero means that this variable has been explicitly declared
1028 special (with `defvar' etc), and shouldn't be lexically bound. */
1029 unsigned declared_special : 1;
1023 1030
1024 /* The symbol's name, as a Lisp string. 1031 /* The symbol's name, as a Lisp string.
1025 1032
@@ -1475,7 +1482,7 @@ struct Lisp_Float
1475typedef unsigned char UCHAR; 1482typedef unsigned char UCHAR;
1476#endif 1483#endif
1477 1484
1478/* Meanings of slots in a Lisp_Compiled: */ 1485/* Meanings of slots in a byte-compiled function vector: */
1479 1486
1480#define COMPILED_ARGLIST 0 1487#define COMPILED_ARGLIST 0
1481#define COMPILED_BYTECODE 1 1488#define COMPILED_BYTECODE 1
@@ -1483,6 +1490,25 @@ typedef unsigned char UCHAR;
1483#define COMPILED_STACK_DEPTH 3 1490#define COMPILED_STACK_DEPTH 3
1484#define COMPILED_DOC_STRING 4 1491#define COMPILED_DOC_STRING 4
1485#define COMPILED_INTERACTIVE 5 1492#define COMPILED_INTERACTIVE 5
1493#define COMPILED_PUSH_ARGS 6
1494
1495/* Return non-zero if TAG, the first element from a funvec object, refers
1496 to a byte-code object. Byte-code objects are distinguished from other
1497 `funvec' objects by having a (possibly empty) list as their first
1498 element -- other funvec types use a non-nil symbol there. */
1499#define FUNVEC_COMPILED_TAG_P(tag) \
1500 (NILP (tag) || CONSP (tag))
1501
1502/* Return non-zero if FUNVEC, which should be a `funvec' object, is a
1503 byte-compiled function. Byte-compiled function are funvecs with the
1504 arglist as the first element (other funvec types will have a symbol
1505 identifying the type as the first object). */
1506#define FUNVEC_COMPILED_P(funvec) \
1507 (FUNVEC_SIZE (funvec) > 0 && FUNVEC_COMPILED_TAG_P (AREF (funvec, 0)))
1508
1509/* Return non-zero if OBJ is byte-compile function. */
1510#define COMPILEDP(obj) \
1511 (FUNVECP (obj) && FUNVEC_COMPILED_P (obj))
1486 1512
1487/* Flag bits in a character. These also get used in termhooks.h. 1513/* Flag bits in a character. These also get used in termhooks.h.
1488 Richard Stallman <rms@gnu.ai.mit.edu> thinks that MULE 1514 Richard Stallman <rms@gnu.ai.mit.edu> thinks that MULE
@@ -1604,7 +1630,7 @@ typedef struct {
1604#define WINDOWP(x) PSEUDOVECTORP (x, PVEC_WINDOW) 1630#define WINDOWP(x) PSEUDOVECTORP (x, PVEC_WINDOW)
1605#define TERMINALP(x) PSEUDOVECTORP (x, PVEC_TERMINAL) 1631#define TERMINALP(x) PSEUDOVECTORP (x, PVEC_TERMINAL)
1606#define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR) 1632#define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR)
1607#define COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED) 1633#define FUNVECP(x) PSEUDOVECTORP (x, PVEC_FUNVEC)
1608#define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER) 1634#define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER)
1609#define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE) 1635#define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE)
1610#define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE) 1636#define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE)
@@ -1797,7 +1823,7 @@ typedef struct {
1797#define FUNCTIONP(OBJ) \ 1823#define FUNCTIONP(OBJ) \
1798 ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ 1824 ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \
1799 || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ 1825 || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \
1800 || COMPILEDP (OBJ) \ 1826 || FUNVECP (OBJ) \
1801 || SUBRP (OBJ)) 1827 || SUBRP (OBJ))
1802 1828
1803/* defsubr (Sname); 1829/* defsubr (Sname);
@@ -2697,6 +2723,7 @@ EXFUN (Fmake_list, 2);
2697extern Lisp_Object allocate_misc P_ ((void)); 2723extern Lisp_Object allocate_misc P_ ((void));
2698EXFUN (Fmake_vector, 2); 2724EXFUN (Fmake_vector, 2);
2699EXFUN (Fvector, MANY); 2725EXFUN (Fvector, MANY);
2726EXFUN (Ffunvec, MANY);
2700EXFUN (Fmake_symbol, 1); 2727EXFUN (Fmake_symbol, 1);
2701EXFUN (Fmake_marker, 0); 2728EXFUN (Fmake_marker, 0);
2702EXFUN (Fmake_string, 2); 2729EXFUN (Fmake_string, 2);
@@ -2715,6 +2742,7 @@ extern Lisp_Object make_pure_c_string (const char *data);
2715extern Lisp_Object pure_cons P_ ((Lisp_Object, Lisp_Object)); 2742extern Lisp_Object pure_cons P_ ((Lisp_Object, Lisp_Object));
2716extern Lisp_Object make_pure_vector P_ ((EMACS_INT)); 2743extern Lisp_Object make_pure_vector P_ ((EMACS_INT));
2717EXFUN (Fgarbage_collect, 0); 2744EXFUN (Fgarbage_collect, 0);
2745extern Lisp_Object make_funvec P_ ((Lisp_Object, int, int, Lisp_Object *));
2718EXFUN (Fmake_byte_code, MANY); 2746EXFUN (Fmake_byte_code, MANY);
2719EXFUN (Fmake_bool_vector, 2); 2747EXFUN (Fmake_bool_vector, 2);
2720extern Lisp_Object Qchar_table_extra_slots; 2748extern Lisp_Object Qchar_table_extra_slots;
@@ -2894,7 +2922,7 @@ extern Lisp_Object call5 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object
2894extern Lisp_Object call6 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)); 2922extern Lisp_Object call6 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object));
2895extern Lisp_Object call7 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)); 2923extern Lisp_Object call7 P_ ((Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object));
2896EXFUN (Fdo_auto_save, 2); 2924EXFUN (Fdo_auto_save, 2);
2897extern Lisp_Object apply_lambda P_ ((Lisp_Object, Lisp_Object, int)); 2925extern Lisp_Object apply_lambda P_ ((Lisp_Object, Lisp_Object, int, Lisp_Object));
2898extern Lisp_Object internal_catch P_ ((Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object)); 2926extern Lisp_Object internal_catch P_ ((Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object));
2899extern Lisp_Object internal_lisp_condition_case P_ ((Lisp_Object, Lisp_Object, Lisp_Object)); 2927extern Lisp_Object internal_lisp_condition_case P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
2900extern Lisp_Object internal_condition_case P_ ((Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object))); 2928extern Lisp_Object internal_condition_case P_ ((Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)));
@@ -3312,11 +3340,13 @@ extern int read_bytecode_char P_ ((int));
3312 3340
3313/* Defined in bytecode.c */ 3341/* Defined in bytecode.c */
3314extern Lisp_Object Qbytecode; 3342extern Lisp_Object Qbytecode;
3315EXFUN (Fbyte_code, 3); 3343EXFUN (Fbyte_code, MANY);
3316extern void syms_of_bytecode P_ ((void)); 3344extern void syms_of_bytecode P_ ((void));
3317extern struct byte_stack *byte_stack_list; 3345extern struct byte_stack *byte_stack_list;
3318extern void mark_byte_stack P_ ((void)); 3346extern void mark_byte_stack P_ ((void));
3319extern void unmark_byte_stack P_ ((void)); 3347extern void unmark_byte_stack P_ ((void));
3348extern Lisp_Object exec_byte_code P_ ((Lisp_Object, Lisp_Object, Lisp_Object,
3349 Lisp_Object, int, Lisp_Object *));
3320 3350
3321/* Defined in macros.c */ 3351/* Defined in macros.c */
3322extern Lisp_Object Qexecute_kbd_macro; 3352extern Lisp_Object Qexecute_kbd_macro;
diff --git a/src/lread.c b/src/lread.c
index 3a77a62b27f..53f26faea36 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -83,6 +83,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name;
83Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; 83Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
84Lisp_Object Qinhibit_file_name_operation; 84Lisp_Object Qinhibit_file_name_operation;
85Lisp_Object Qeval_buffer_list, Veval_buffer_list; 85Lisp_Object Qeval_buffer_list, Veval_buffer_list;
86Lisp_Object Qlexical_binding;
86Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ 87Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
87 88
88/* Used instead of Qget_file_char while loading *.elc files compiled 89/* Used instead of Qget_file_char while loading *.elc files compiled
@@ -93,6 +94,7 @@ static Lisp_Object Qload_force_doc_strings;
93 94
94extern Lisp_Object Qevent_symbol_element_mask; 95extern Lisp_Object Qevent_symbol_element_mask;
95extern Lisp_Object Qfile_exists_p; 96extern Lisp_Object Qfile_exists_p;
97extern Lisp_Object Qinternal_interpreter_environment;
96 98
97/* non-zero if inside `load' */ 99/* non-zero if inside `load' */
98int load_in_progress; 100int load_in_progress;
@@ -157,6 +159,9 @@ Lisp_Object Vread_with_symbol_positions;
157/* List of (SYMBOL . POSITION) accumulated so far. */ 159/* List of (SYMBOL . POSITION) accumulated so far. */
158Lisp_Object Vread_symbol_positions_list; 160Lisp_Object Vread_symbol_positions_list;
159 161
162/* If non-nil `readevalloop' evaluates code in a lexical environment. */
163Lisp_Object Vlexical_binding;
164
160/* List of descriptors now open for Fload. */ 165/* List of descriptors now open for Fload. */
161static Lisp_Object load_descriptor_list; 166static Lisp_Object load_descriptor_list;
162 167
@@ -864,6 +869,118 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
864 869
865 870
866 871
872
873/* Return true if the lisp code read using READCHARFUN defines a non-nil
874 `lexical-binding' file variable. After returning, the stream is
875 positioned following the first line, if it is a comment, otherwise
876 nothing is read. */
877
878static int
879lisp_file_lexically_bound_p (readcharfun)
880 Lisp_Object readcharfun;
881{
882 int ch = READCHAR;
883 if (ch != ';')
884 /* The first line isn't a comment, just give up. */
885 {
886 UNREAD (ch);
887 return 0;
888 }
889 else
890 /* Look for an appropriate file-variable in the first line. */
891 {
892 int rv = 0;
893 enum {
894 NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX,
895 } beg_end_state = NOMINAL;
896 int in_file_vars = 0;
897
898#define UPDATE_BEG_END_STATE(ch) \
899 if (beg_end_state == NOMINAL) \
900 beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
901 else if (beg_end_state == AFTER_FIRST_DASH) \
902 beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
903 else if (beg_end_state == AFTER_ASTERIX) \
904 { \
905 if (ch == '-') \
906 in_file_vars = !in_file_vars; \
907 beg_end_state = NOMINAL; \
908 }
909
910 /* Skip until we get to the file vars, if any. */
911 do
912 {
913 ch = READCHAR;
914 UPDATE_BEG_END_STATE (ch);
915 }
916 while (!in_file_vars && ch != '\n' && ch != EOF);
917
918 while (in_file_vars)
919 {
920 char var[100], *var_end, val[100], *val_end;
921
922 ch = READCHAR;
923
924 /* Read a variable name. */
925 while (ch == ' ' || ch == '\t')
926 ch = READCHAR;
927
928 var_end = var;
929 while (ch != ':' && ch != '\n' && ch != EOF)
930 {
931 if (var_end < var + sizeof var - 1)
932 *var_end++ = ch;
933 UPDATE_BEG_END_STATE (ch);
934 ch = READCHAR;
935 }
936
937 while (var_end > var
938 && (var_end[-1] == ' ' || var_end[-1] == '\t'))
939 var_end--;
940 *var_end = '\0';
941
942 if (ch == ':')
943 {
944 /* Read a variable value. */
945 ch = READCHAR;
946
947 while (ch == ' ' || ch == '\t')
948 ch = READCHAR;
949
950 val_end = val;
951 while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
952 {
953 if (val_end < val + sizeof val - 1)
954 *val_end++ = ch;
955 UPDATE_BEG_END_STATE (ch);
956 ch = READCHAR;
957 }
958 if (! in_file_vars)
959 /* The value was terminated by an end-marker, which
960 remove. */
961 val_end -= 3;
962 while (val_end > val
963 && (val_end[-1] == ' ' || val_end[-1] == '\t'))
964 val_end--;
965 *val_end = '\0';
966
967 if (strcmp (var, "lexical-binding") == 0)
968 /* This is it... */
969 {
970 rv = (strcmp (val, "nil") != 0);
971 break;
972 }
973 }
974 }
975
976 while (ch != '\n' && ch != EOF)
977 ch = READCHAR;
978
979 return rv;
980 }
981}
982
983
867/* Value is a version number of byte compiled code if the file 984/* Value is a version number of byte compiled code if the file
868 associated with file descriptor FD is a compiled Lisp file that's 985 associated with file descriptor FD is a compiled Lisp file that's
869 safe to load. Only files compiled with Emacs are safe to load. 986 safe to load. Only files compiled with Emacs are safe to load.
@@ -1129,6 +1246,12 @@ Return t if the file exists and loads successfully. */)
1129 Vloads_in_progress = Fcons (found, Vloads_in_progress); 1246 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1130 } 1247 }
1131 1248
1249 /* All loads are by default dynamic, unless the file itself specifies
1250 otherwise using a file-variable in the first line. This is bound here
1251 so that it takes effect whether or not we use
1252 Vload_source_file_function. */
1253 specbind (Qlexical_binding, Qnil);
1254
1132 /* Get the name for load-history. */ 1255 /* Get the name for load-history. */
1133 hist_file_name = (! NILP (Vpurify_flag) 1256 hist_file_name = (! NILP (Vpurify_flag)
1134 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), 1257 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
@@ -1253,7 +1376,13 @@ Return t if the file exists and loads successfully. */)
1253 specbind (Qinhibit_file_name_operation, Qnil); 1376 specbind (Qinhibit_file_name_operation, Qnil);
1254 load_descriptor_list 1377 load_descriptor_list
1255 = Fcons (make_number (fileno (stream)), load_descriptor_list); 1378 = Fcons (make_number (fileno (stream)), load_descriptor_list);
1379
1256 specbind (Qload_in_progress, Qt); 1380 specbind (Qload_in_progress, Qt);
1381
1382 instream = stream;
1383 if (lisp_file_lexically_bound_p (Qget_file_char))
1384 Fset (Qlexical_binding, Qt);
1385
1257 if (! version || version >= 22) 1386 if (! version || version >= 22)
1258 readevalloop (Qget_file_char, stream, hist_file_name, 1387 readevalloop (Qget_file_char, stream, hist_file_name,
1259 Feval, 0, Qnil, Qnil, Qnil, Qnil); 1388 Feval, 0, Qnil, Qnil, Qnil, Qnil);
@@ -1652,6 +1781,7 @@ readevalloop (readcharfun, stream, sourcename, evalfun,
1652 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 1781 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1653 struct buffer *b = 0; 1782 struct buffer *b = 0;
1654 int continue_reading_p; 1783 int continue_reading_p;
1784 Lisp_Object lex_bound;
1655 /* Nonzero if reading an entire buffer. */ 1785 /* Nonzero if reading an entire buffer. */
1656 int whole_buffer = 0; 1786 int whole_buffer = 0;
1657 /* 1 on the first time around. */ 1787 /* 1 on the first time around. */
@@ -1677,6 +1807,15 @@ readevalloop (readcharfun, stream, sourcename, evalfun,
1677 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); 1807 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
1678 load_convert_to_unibyte = !NILP (unibyte); 1808 load_convert_to_unibyte = !NILP (unibyte);
1679 1809
1810 /* If lexical binding is active (either because it was specified in
1811 the file's header, or via a buffer-local variable), create an empty
1812 lexical environment, otherwise, turn off lexical binding. */
1813 lex_bound = find_symbol_value (Qlexical_binding);
1814 if (NILP (lex_bound) || EQ (lex_bound, Qunbound))
1815 specbind (Qinternal_interpreter_environment, Qnil);
1816 else
1817 specbind (Qinternal_interpreter_environment, Fcons (Qt, Qnil));
1818
1680 GCPRO4 (sourcename, readfun, start, end); 1819 GCPRO4 (sourcename, readfun, start, end);
1681 1820
1682 /* Try to ensure sourcename is a truename, except whilst preloading. */ 1821 /* Try to ensure sourcename is a truename, except whilst preloading. */
@@ -1837,8 +1976,11 @@ This function preserves the position of point. */)
1837 1976
1838 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); 1977 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
1839 specbind (Qstandard_output, tem); 1978 specbind (Qstandard_output, tem);
1979 specbind (Qlexical_binding, Qnil);
1840 record_unwind_protect (save_excursion_restore, save_excursion_save ()); 1980 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1841 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); 1981 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1982 if (lisp_file_lexically_bound_p (buf))
1983 Fset (Qlexical_binding, Qt);
1842 readevalloop (buf, 0, filename, Feval, 1984 readevalloop (buf, 0, filename, Feval,
1843 !NILP (printflag), unibyte, Qnil, Qnil, Qnil); 1985 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
1844 unbind_to (count, Qnil); 1986 unbind_to (count, Qnil);
@@ -2481,14 +2623,8 @@ read1 (readcharfun, pch, first_in_list)
2481 invalid_syntax ("#&...", 5); 2623 invalid_syntax ("#&...", 5);
2482 } 2624 }
2483 if (c == '[') 2625 if (c == '[')
2484 { 2626 /* `function vector' objects, including byte-compiled functions. */
2485 /* Accept compiled functions at read-time so that we don't have to 2627 return read_vector (readcharfun, 1);
2486 build them using function calls. */
2487 Lisp_Object tmp;
2488 tmp = read_vector (readcharfun, 1);
2489 return Fmake_byte_code (XVECTOR (tmp)->size,
2490 XVECTOR (tmp)->contents);
2491 }
2492 if (c == '(') 2628 if (c == '(')
2493 { 2629 {
2494 Lisp_Object tmp; 2630 Lisp_Object tmp;
@@ -3300,9 +3436,9 @@ isfloat_string (cp, ignore_trailing)
3300 3436
3301 3437
3302static Lisp_Object 3438static Lisp_Object
3303read_vector (readcharfun, bytecodeflag) 3439read_vector (readcharfun, read_funvec)
3304 Lisp_Object readcharfun; 3440 Lisp_Object readcharfun;
3305 int bytecodeflag; 3441 int read_funvec;
3306{ 3442{
3307 register int i; 3443 register int i;
3308 register int size; 3444 register int size;
@@ -3310,6 +3446,11 @@ read_vector (readcharfun, bytecodeflag)
3310 register Lisp_Object tem, item, vector; 3446 register Lisp_Object tem, item, vector;
3311 register struct Lisp_Cons *otem; 3447 register struct Lisp_Cons *otem;
3312 Lisp_Object len; 3448 Lisp_Object len;
3449 /* If we're reading a funvec object we start out assuming it's also a
3450 byte-code object (a subset of funvecs), so we can do any special
3451 processing needed. If it's just an ordinary funvec object, we'll
3452 realize that as soon as we've read the first element. */
3453 int read_bytecode = read_funvec;
3313 3454
3314 tem = read_list (1, readcharfun); 3455 tem = read_list (1, readcharfun);
3315 len = Flength (tem); 3456 len = Flength (tem);
@@ -3320,11 +3461,19 @@ read_vector (readcharfun, bytecodeflag)
3320 for (i = 0; i < size; i++) 3461 for (i = 0; i < size; i++)
3321 { 3462 {
3322 item = Fcar (tem); 3463 item = Fcar (tem);
3464
3465 /* If READ_BYTECODE is set, check whether this is really a byte-code
3466 object, or just an ordinary `funvec' object -- non-byte-code
3467 funvec objects use the same reader syntax. We can tell from the
3468 first element which one it is. */
3469 if (read_bytecode && i == 0 && ! FUNVEC_COMPILED_TAG_P (item))
3470 read_bytecode = 0; /* Nope. */
3471
3323 /* If `load-force-doc-strings' is t when reading a lazily-loaded 3472 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3324 bytecode object, the docstring containing the bytecode and 3473 bytecode object, the docstring containing the bytecode and
3325 constants values must be treated as unibyte and passed to 3474 constants values must be treated as unibyte and passed to
3326 Fread, to get the actual bytecode string and constants vector. */ 3475 Fread, to get the actual bytecode string and constants vector. */
3327 if (bytecodeflag && load_force_doc_strings) 3476 if (read_bytecode && load_force_doc_strings)
3328 { 3477 {
3329 if (i == COMPILED_BYTECODE) 3478 if (i == COMPILED_BYTECODE)
3330 { 3479 {
@@ -3377,6 +3526,14 @@ read_vector (readcharfun, bytecodeflag)
3377 tem = Fcdr (tem); 3526 tem = Fcdr (tem);
3378 free_cons (otem); 3527 free_cons (otem);
3379 } 3528 }
3529
3530 if (read_bytecode && size >= 4)
3531 /* Convert this vector to a bytecode object. */
3532 vector = Fmake_byte_code (size, XVECTOR (vector)->contents);
3533 else if (read_funvec && size >= 1)
3534 /* Convert this vector to an ordinary funvec object. */
3535 XSETFUNVEC (vector, XVECTOR (vector));
3536
3380 return vector; 3537 return vector;
3381} 3538}
3382 3539
@@ -3979,6 +4136,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd,
3979 sym = intern_c_string (namestring); 4136 sym = intern_c_string (namestring);
3980 i_fwd->type = Lisp_Fwd_Int; 4137 i_fwd->type = Lisp_Fwd_Int;
3981 i_fwd->intvar = address; 4138 i_fwd->intvar = address;
4139 XSYMBOL (sym)->declared_special = 1;
3982 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4140 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3983 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); 4141 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
3984} 4142}
@@ -3993,6 +4151,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd,
3993 sym = intern_c_string (namestring); 4151 sym = intern_c_string (namestring);
3994 b_fwd->type = Lisp_Fwd_Bool; 4152 b_fwd->type = Lisp_Fwd_Bool;
3995 b_fwd->boolvar = address; 4153 b_fwd->boolvar = address;
4154 XSYMBOL (sym)->declared_special = 1;
3996 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4155 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3997 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); 4156 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
3998 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); 4157 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
@@ -4011,6 +4170,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd,
4011 sym = intern_c_string (namestring); 4170 sym = intern_c_string (namestring);
4012 o_fwd->type = Lisp_Fwd_Obj; 4171 o_fwd->type = Lisp_Fwd_Obj;
4013 o_fwd->objvar = address; 4172 o_fwd->objvar = address;
4173 XSYMBOL (sym)->declared_special = 1;
4014 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4174 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4015 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); 4175 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
4016} 4176}
@@ -4023,6 +4183,7 @@ defvar_lisp (struct Lisp_Objfwd *o_fwd,
4023 staticpro (address); 4183 staticpro (address);
4024} 4184}
4025 4185
4186
4026/* Similar but define a variable whose value is the Lisp Object stored 4187/* Similar but define a variable whose value is the Lisp Object stored
4027 at a particular offset in the current kboard object. */ 4188 at a particular offset in the current kboard object. */
4028 4189
@@ -4034,6 +4195,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd,
4034 sym = intern_c_string (namestring); 4195 sym = intern_c_string (namestring);
4035 ko_fwd->type = Lisp_Fwd_Kboard_Obj; 4196 ko_fwd->type = Lisp_Fwd_Kboard_Obj;
4036 ko_fwd->offset = offset; 4197 ko_fwd->offset = offset;
4198 XSYMBOL (sym)->declared_special = 1;
4037 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4199 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4038 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); 4200 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
4039} 4201}
@@ -4463,6 +4625,16 @@ to load. See also `load-dangerous-libraries'. */);
4463 Vbytecomp_version_regexp 4625 Vbytecomp_version_regexp
4464 = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); 4626 = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4465 4627
4628 Qlexical_binding = intern ("lexical-binding");
4629 staticpro (&Qlexical_binding);
4630 DEFVAR_LISP ("lexical-binding", &Vlexical_binding,
4631 doc: /* If non-nil, use lexical binding when evaluating code.
4632This only applies to code evaluated by `eval-buffer' and `eval-region'.
4633This variable is automatically set from the file variables of an interpreted
4634 lisp file read using `load'.
4635This variable automatically becomes buffer-local when set. */);
4636 Fmake_variable_buffer_local (Qlexical_binding);
4637
4466 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list, 4638 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list,
4467 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); 4639 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4468 Veval_buffer_list = Qnil; 4640 Veval_buffer_list = Qnil;
diff --git a/src/print.c b/src/print.c
index 6d403e00fe0..fb298233666 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1340,7 +1340,7 @@ print_preprocess (obj)
1340 1340
1341 loop: 1341 loop:
1342 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) 1342 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1343 || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) 1343 || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1344 || HASH_TABLE_P (obj) 1344 || HASH_TABLE_P (obj)
1345 || (! NILP (Vprint_gensym) 1345 || (! NILP (Vprint_gensym)
1346 && SYMBOLP (obj) 1346 && SYMBOLP (obj)
@@ -1543,7 +1543,7 @@ print_object (obj, printcharfun, escapeflag)
1543 1543
1544 /* Detect circularities and truncate them. */ 1544 /* Detect circularities and truncate them. */
1545 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) 1545 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj)
1546 || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) 1546 || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)
1547 || HASH_TABLE_P (obj) 1547 || HASH_TABLE_P (obj)
1548 || (! NILP (Vprint_gensym) 1548 || (! NILP (Vprint_gensym)
1549 && SYMBOLP (obj) 1549 && SYMBOLP (obj)
@@ -2175,7 +2175,7 @@ print_object (obj, printcharfun, escapeflag)
2175 else 2175 else
2176 { 2176 {
2177 EMACS_INT size = XVECTOR (obj)->size; 2177 EMACS_INT size = XVECTOR (obj)->size;
2178 if (COMPILEDP (obj)) 2178 if (FUNVECP (obj))
2179 { 2179 {
2180 PRINTCHAR ('#'); 2180 PRINTCHAR ('#');
2181 size &= PSEUDOVECTOR_SIZE_MASK; 2181 size &= PSEUDOVECTOR_SIZE_MASK;
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-16 18:58:30 +0000