aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el2
-rw-r--r--doc/lispref/ChangeLog10
-rw-r--r--doc/lispref/eval.texi10
-rw-r--r--doc/lispref/variables.texi149
-rw-r--r--etc/NEWS24
-rw-r--r--lisp/ChangeLog202
-rw-r--r--lisp/Makefile.in26
-rw-r--r--lisp/abbrev.el29
-rw-r--r--lisp/cedet/ChangeLog5
-rw-r--r--lisp/cedet/semantic/wisent/comp.el21
-rw-r--r--lisp/custom.el39
-rw-r--r--lisp/dired.el32
-rw-r--r--lisp/doc-view.el43
-rw-r--r--lisp/emacs-lisp/advice.el16
-rw-r--r--lisp/emacs-lisp/autoload.el5
-rw-r--r--lisp/emacs-lisp/byte-opt.el441
-rw-r--r--lisp/emacs-lisp/byte-run.el10
-rw-r--r--lisp/emacs-lisp/bytecomp.el2098
-rw-r--r--lisp/emacs-lisp/cconv.el713
-rw-r--r--lisp/emacs-lisp/cl-extra.el23
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el39
-rw-r--r--lisp/emacs-lisp/cl-macs.el64
-rw-r--r--lisp/emacs-lisp/cl.el15
-rw-r--r--lisp/emacs-lisp/disass.el13
-rw-r--r--lisp/emacs-lisp/edebug.el21
-rw-r--r--lisp/emacs-lisp/eieio-comp.el142
-rw-r--r--lisp/emacs-lisp/eieio.el59
-rw-r--r--lisp/emacs-lisp/float-sup.el8
-rw-r--r--lisp/emacs-lisp/lisp-mode.el37
-rw-r--r--lisp/emacs-lisp/macroexp.el43
-rw-r--r--lisp/emacs-lisp/pcase.el205
-rw-r--r--lisp/emacs-lisp/smie.el4
-rw-r--r--lisp/files.el25
-rw-r--r--lisp/follow.el3
-rw-r--r--lisp/gnus/ChangeLog5
-rw-r--r--lisp/gnus/mm-view.el4
-rw-r--r--lisp/help-fns.el64
-rw-r--r--lisp/ielm.el3
-rw-r--r--lisp/info.el21
-rw-r--r--lisp/makefile.w32-in33
-rw-r--r--lisp/minibuffer.el562
-rw-r--r--lisp/mpc.el55
-rw-r--r--lisp/newcomment.el4
-rw-r--r--lisp/reveal.el2
-rw-r--r--lisp/server.el144
-rw-r--r--lisp/simple.el100
-rw-r--r--lisp/startup.el257
-rw-r--r--lisp/subr.el215
-rw-r--r--lisp/textmodes/bibtex-style.el4
-rw-r--r--lisp/textmodes/css-mode.el2
-rw-r--r--lisp/uniquify.el2
-rw-r--r--lisp/vc/cvs-status.el46
-rw-r--r--lisp/vc/diff-mode.el57
-rw-r--r--lisp/vc/log-edit.el6
-rw-r--r--lisp/vc/log-view.el3
-rw-r--r--lisp/vc/smerge-mode.el2
-rw-r--r--src/ChangeLog58
-rw-r--r--src/alloc.c14
-rw-r--r--src/buffer.c1
-rw-r--r--src/bytecode.c163
-rw-r--r--src/callint.c13
-rw-r--r--src/data.c8
-rw-r--r--src/doc.c7
-rw-r--r--src/eval.c382
-rw-r--r--src/fns.c4
-rw-r--r--src/image.c4
-rw-r--r--src/keyboard.c12
-rw-r--r--src/lisp.h12
-rw-r--r--src/lread.c162
-rw-r--r--src/minibuf.c3
-rw-r--r--src/print.c57
-rw-r--r--src/window.c34
-rw-r--r--src/window.h1
-rw-r--r--test/ChangeLog4
-rw-r--r--test/automated/lexbind-tests.el75
75 files changed, 4684 insertions, 2497 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index f098f3e7460..86410cc8f40 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -1,6 +1,6 @@
1((nil . ((tab-width . 8) 1((nil . ((tab-width . 8)
2 (sentence-end-double-space . t) 2 (sentence-end-double-space . t)
3 (fill-column . 70))) 3 (fill-column . 79)))
4 (c-mode . ((c-file-style . "GNU"))) 4 (c-mode . ((c-file-style . "GNU")))
5 ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work. 5 ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work.
6 ;; See admin/notes/bugtracker. 6 ;; See admin/notes/bugtracker.
diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog
index 1eb3cfa2556..faa5fa44e46 100644
--- a/doc/lispref/ChangeLog
+++ b/doc/lispref/ChangeLog
@@ -1,6 +1,14 @@
12011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * variables.texi (Defining Variables): Mention the new meaning of `defvar'.
4 (Lexical Binding): New sub-section.
5
6 * eval.texi (Eval): Discourage the use of `eval'.
7 Document its new `lexical' argument.
8
12011-03-28 Stefan Monnier <monnier@iro.umontreal.ca> 92011-03-28 Stefan Monnier <monnier@iro.umontreal.ca>
2 10
3 * commands.texi (Command Overview): post-command-hook is not reset to 11 * commands.texi (Command Overview): `post-command-hook' is not reset to
4 nil any more. 12 nil any more.
5 13
62011-03-19 Stefan Monnier <monnier@iro.umontreal.ca> 142011-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index d44fe5bb95b..74f3d9c48b9 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -585,6 +585,11 @@ occurrence in a program being run. On rare occasions, you may need to
585write code that evaluates a form that is computed at run time, such as 585write code that evaluates a form that is computed at run time, such as
586after reading a form from text being edited or getting one from a 586after reading a form from text being edited or getting one from a
587property list. On these occasions, use the @code{eval} function. 587property list. On these occasions, use the @code{eval} function.
588Often @code{eval} is not needed and something else should be used instead.
589For example, to get the value of a variable, while @code{eval} works,
590@code{symbol-value} is preferable; or rather than store expressions
591in a property list that then need to go through @code{eval}, it is better to
592store functions instead that are then passed to @code{funcall}.
588 593
589 The functions and variables described in this section evaluate forms, 594 The functions and variables described in this section evaluate forms,
590specify limits to the evaluation process, or record recently returned 595specify limits to the evaluation process, or record recently returned
@@ -596,10 +601,13 @@ to store an expression in the data structure and evaluate it. Using
596functions provides the ability to pass information to them as 601functions provides the ability to pass information to them as
597arguments. 602arguments.
598 603
599@defun eval form 604@defun eval form &optional lexical
600This is the basic function evaluating an expression. It evaluates 605This is the basic function evaluating an expression. It evaluates
601@var{form} in the current environment and returns the result. How the 606@var{form} in the current environment and returns the result. How the
602evaluation proceeds depends on the type of the object (@pxref{Forms}). 607evaluation proceeds depends on the type of the object (@pxref{Forms}).
608@var{lexical} if non-nil means to evaluate @var{form} using lexical scoping
609rules (@pxref{Lexical Binding}) instead of the default dynamic scoping used
610historically in Emacs Lisp.
603 611
604Since @code{eval} is a function, the argument expression that appears 612Since @code{eval} is a function, the argument expression that appears
605in a call to @code{eval} is evaluated twice: once as preparation before 613in a call to @code{eval} is evaluated twice: once as preparation before
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index a68b2b6dd4e..7e2c32334a4 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -25,22 +25,22 @@ textual Lisp program is written using the read syntax for the symbol
25representing the variable. 25representing the variable.
26 26
27@menu 27@menu
28* Global Variables:: Variable values that exist permanently, everywhere. 28* Global Variables:: Variable values that exist permanently, everywhere.
29* Constant Variables:: Certain "variables" have values that never change. 29* Constant Variables:: Certain "variables" have values that never change.
30* Local Variables:: Variable values that exist only temporarily. 30* Local Variables:: Variable values that exist only temporarily.
31* Void Variables:: Symbols that lack values. 31* Void Variables:: Symbols that lack values.
32* Defining Variables:: A definition says a symbol is used as a variable. 32* Defining Variables:: A definition says a symbol is used as a variable.
33* Tips for Defining:: Things you should think about when you 33* Tips for Defining:: Things you should think about when you
34 define a variable. 34 define a variable.
35* Accessing Variables:: Examining values of variables whose names 35* Accessing Variables:: Examining values of variables whose names
36 are known only at run time. 36 are known only at run time.
37* Setting Variables:: Storing new values in variables. 37* Setting Variables:: Storing new values in variables.
38* Variable Scoping:: How Lisp chooses among local and global values. 38* Variable Scoping:: How Lisp chooses among local and global values.
39* Buffer-Local Variables:: Variable values in effect only in one buffer. 39* Buffer-Local Variables:: Variable values in effect only in one buffer.
40* File Local Variables:: Handling local variable lists in files. 40* File Local Variables:: Handling local variable lists in files.
41* Directory Local Variables:: Local variables common to all files in a directory. 41* Directory Local Variables:: Local variables common to all files in a directory.
42* Frame-Local Variables:: Frame-local bindings for variables. 42* Frame-Local Variables:: Frame-local bindings for variables.
43* Variable Aliases:: Variables that are aliases for other variables. 43* Variable Aliases:: Variables that are aliases for other variables.
44* Variables with Restricted Values:: Non-constant variables whose value can 44* Variables with Restricted Values:: Non-constant variables whose value can
45 @emph{not} be an arbitrary Lisp object. 45 @emph{not} be an arbitrary Lisp object.
46@end menu 46@end menu
@@ -437,14 +437,18 @@ this reason, user options must be defined with @code{defvar}.
437This special form defines @var{symbol} as a variable and can also 437This special form defines @var{symbol} as a variable and can also
438initialize and document it. The definition informs a person reading 438initialize and document it. The definition informs a person reading
439your code that @var{symbol} is used as a variable that might be set or 439your code that @var{symbol} is used as a variable that might be set or
440changed. Note that @var{symbol} is not evaluated; the symbol to be 440changed. It also declares this variable as @dfn{special}, meaning that it
441defined must appear explicitly in the @code{defvar}. 441should always use dynamic scoping rules. Note that @var{symbol} is not
442evaluated; the symbol to be defined must appear explicitly in the
443@code{defvar}.
442 444
443If @var{symbol} is void and @var{value} is specified, @code{defvar} 445If @var{symbol} is void and @var{value} is specified, @code{defvar}
444evaluates it and sets @var{symbol} to the result. But if @var{symbol} 446evaluates it and sets @var{symbol} to the result. But if @var{symbol}
445already has a value (i.e., it is not void), @var{value} is not even 447already has a value (i.e., it is not void), @var{value} is not even
446evaluated, and @var{symbol}'s value remains unchanged. If @var{value} 448evaluated, and @var{symbol}'s value remains unchanged.
447is omitted, the value of @var{symbol} is not changed in any case. 449If @var{value} is omitted, the value of @var{symbol} is not changed in any
450case; instead, the only effect of @code{defvar} is to declare locally that this
451variable exists elsewhere and should hence always use dynamic scoping rules.
448 452
449If @var{symbol} has a buffer-local binding in the current buffer, 453If @var{symbol} has a buffer-local binding in the current buffer,
450@code{defvar} operates on the default value, which is buffer-independent, 454@code{defvar} operates on the default value, which is buffer-independent,
@@ -881,7 +885,7 @@ the others.
881@cindex extent 885@cindex extent
882@cindex dynamic scoping 886@cindex dynamic scoping
883@cindex lexical scoping 887@cindex lexical scoping
884 Local bindings in Emacs Lisp have @dfn{indefinite scope} and 888 By default, local bindings in Emacs Lisp have @dfn{indefinite scope} and
885@dfn{dynamic extent}. @dfn{Scope} refers to @emph{where} textually in 889@dfn{dynamic extent}. @dfn{Scope} refers to @emph{where} textually in
886the source code the binding can be accessed. ``Indefinite scope'' means 890the source code the binding can be accessed. ``Indefinite scope'' means
887that any part of the program can potentially access the variable 891that any part of the program can potentially access the variable
@@ -893,6 +897,8 @@ lasts as long as the activation of the construct that established it.
893@dfn{dynamic scoping}. By contrast, most programming languages use 897@dfn{dynamic scoping}. By contrast, most programming languages use
894@dfn{lexical scoping}, in which references to a local variable must be 898@dfn{lexical scoping}, in which references to a local variable must be
895located textually within the function or block that binds the variable. 899located textually within the function or block that binds the variable.
900Emacs can also support lexical scoping, upon request (@pxref{Lexical
901Binding}).
896 902
897@cindex CL note---special variables 903@cindex CL note---special variables
898@quotation 904@quotation
@@ -901,11 +907,12 @@ dynamically scoped, like all variables in Emacs Lisp.
901@end quotation 907@end quotation
902 908
903@menu 909@menu
904* Scope:: Scope means where in the program a value is visible. 910* Scope:: Scope means where in the program a value is visible.
905 Comparison with other languages. 911 Comparison with other languages.
906* Extent:: Extent means how long in time a value exists. 912* Extent:: Extent means how long in time a value exists.
907* Impl of Scope:: Two ways to implement dynamic scoping. 913* Impl of Scope:: Two ways to implement dynamic scoping.
908* Using Scoping:: How to use dynamic scoping carefully and avoid problems. 914* Using Scoping:: How to use dynamic scoping carefully and avoid problems.
915* Lexical Binding:: Use of lexical scoping.
909@end menu 916@end menu
910 917
911@node Scope 918@node Scope
@@ -969,12 +976,12 @@ Here, when @code{foo} is called by @code{binder}, it binds @code{x}.
969by @code{foo} instead of the one bound by @code{binder}. 976by @code{foo} instead of the one bound by @code{binder}.
970@end itemize 977@end itemize
971 978
972Emacs Lisp uses dynamic scoping because simple implementations of 979Emacs Lisp used dynamic scoping by default because simple implementations of
973lexical scoping are slow. In addition, every Lisp system needs to offer 980lexical scoping are slow. In addition, every Lisp system needs to offer
974dynamic scoping at least as an option; if lexical scoping is the norm, 981dynamic scoping at least as an option; if lexical scoping is the norm, there
975there must be a way to specify dynamic scoping instead for a particular 982must be a way to specify dynamic scoping instead for a particular variable.
976variable. It might not be a bad thing for Emacs to offer both, but 983Nowadays, Emacs offers both, but the default is still to use exclusively
977implementing it with dynamic scoping only was much easier. 984dynamic scoping.
978 985
979@node Extent 986@node Extent
980@subsection Extent 987@subsection Extent
@@ -1088,6 +1095,86 @@ for inter-function usage. It also avoids a warning from the byte
1088compiler. Choose the variable's name to avoid name conflicts---don't 1095compiler. Choose the variable's name to avoid name conflicts---don't
1089use short names like @code{x}. 1096use short names like @code{x}.
1090 1097
1098
1099@node Lexical Binding
1100@subsection Use of Lexical Scoping
1101
1102Emacs Lisp can be evaluated in two different modes: in dynamic binding mode or
1103lexical binding mode. In dynamic binding mode, all local variables use dynamic
1104scoping, whereas in lexical binding mode variables that have been declared
1105@dfn{special} (i.e., declared with @code{defvar} or @code{defconst}) use
1106dynamic scoping and all others use lexical scoping.
1107
1108@defvar lexical-binding
1109When non-nil, evaluation of Lisp code uses lexical scoping for non-special
1110local variables instead of dynamic scoping. If nil, dynamic scoping is used
1111for all local variables. This variable is typically set for a whole Elisp file
1112via file local variables (@pxref{File Local Variables}).
1113@end defvar
1114
1115@defun special-variable-p SYMBOL
1116Return whether SYMBOL has been declared as a special variable, via
1117@code{defvar} or @code{defconst}.
1118@end defun
1119
1120The use of a special variable as a formal argument in a function is generally
1121discouraged and its behavior in lexical binding mode is unspecified (it may use
1122lexical scoping sometimes and dynamic scoping other times).
1123
1124Functions like @code{symbol-value}, @code{boundp}, or @code{set} only know
1125about dynamically scoped variables, so you cannot get the value of a lexical
1126variable via @code{symbol-value} and neither can you change it via @code{set}.
1127Another particularity is that code in the body of a @code{defun} or
1128@code{defmacro} cannot refer to surrounding lexical variables.
1129
1130Evaluation of a @code{lambda} expression in lexical binding mode will not just
1131return that lambda expression unchanged, as in the dynamic binding case, but
1132will instead construct a new object that remembers the current lexical
1133environment in which that lambda expression was defined, so that the function
1134body can later be evaluated in the proper context. Those objects are called
1135@dfn{closures}. They are also functions, in the sense that they are accepted
1136by @code{funcall}, and they are represented by a cons cell whose @code{car} is
1137the symbol @code{closure}.
1138
1139@menu
1140* Converting to Lexical Binding:: How to start using lexical scoping
1141@end menu
1142
1143@node Converting to Lexical Binding
1144@subsubsection Converting a package to use lexical scoping
1145
1146Lexical scoping, as currently implemented, does not bring many significant
1147benefits, unless you are a seasoned functional programmer addicted to
1148higher-order functions. But its importance will increase in the future:
1149lexical scoping opens up a lot more opportunities for optimization, so
1150lexically scoped code is likely to run faster in future Emacs versions, and it
1151is much more friendly to concurrency, which we want to add in the near future.
1152
1153Converting a package to lexical binding is usually pretty easy and should not
1154break backward compatibility: just add a file-local variable setting
1155@code{lexical-binding} to @code{t} and add declarations of the form
1156@code{(defvar @var{VAR})} for every variable which still needs to use
1157dynamic scoping.
1158
1159To find which variables need this declaration, the simplest solution is to
1160check the byte-compiler's warnings. The byte-compiler will usually find those
1161variables either because they are used outside of a let-binding (leading to
1162warnings about reference or assignment to ``free variable @var{VAR}'') or
1163because they are let-bound but not used within the let-binding (leading to
1164warnings about ``unused lexical variable @var{VAR}'').
1165
1166In cases where a dynamically scoped variable was bound as a function argument,
1167you will also need to move this binding to a @code{let}. These cases are also
1168flagged by the byte-compiler.
1169
1170To silence byte-compiler warnings about unused variables, just use a variable
1171name that start with an underscore, which the byte-compiler interpret as an
1172indication that this is a variable known not to be used.
1173
1174In most cases, the resulting code will then work with either setting of
1175@code{lexical-binding}, so it can still be used with older Emacsen (which will
1176simply ignore the @code{lexical-binding} variable setting).
1177
1091@node Buffer-Local Variables 1178@node Buffer-Local Variables
1092@section Buffer-Local Variables 1179@section Buffer-Local Variables
1093@cindex variable, buffer-local 1180@cindex variable, buffer-local
@@ -1103,9 +1190,9 @@ local to each terminal, or to each frame. @xref{Multiple Terminals},
1103and @xref{Frame-Local Variables}.) 1190and @xref{Frame-Local Variables}.)
1104 1191
1105@menu 1192@menu
1106* Intro to Buffer-Local:: Introduction and concepts. 1193* Intro to Buffer-Local:: Introduction and concepts.
1107* Creating Buffer-Local:: Creating and destroying buffer-local bindings. 1194* Creating Buffer-Local:: Creating and destroying buffer-local bindings.
1108* Default Value:: The default value is seen in buffers 1195* Default Value:: The default value is seen in buffers
1109 that don't have their own buffer-local values. 1196 that don't have their own buffer-local values.
1110@end menu 1197@end menu
1111 1198
diff --git a/etc/NEWS b/etc/NEWS
index 14d788ec554..521741100f1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -676,6 +676,14 @@ binding `log-view-expanded-log-entry-function' to a suitable function.
676 676
677*** New command `nato-region' converts text to NATO phonetic alphabet. 677*** New command `nato-region' converts text to NATO phonetic alphabet.
678 678
679*** The new command `info-display-manual' will display an Info manual
680specified by its name. If that manual is already visited in some Info
681buffer within the current session, the command will display that
682buffer. Otherwise, it will load the manual and display it. This is
683handy if you have many manuals in many Info buffers, and don't
684remember the name of the buffer visiting the manual you want to
685consult.
686
679 687
680* New Modes and Packages in Emacs 24.1 688* New Modes and Packages in Emacs 24.1
681 689
@@ -765,6 +773,22 @@ sc.el, x-menu.el, rnews.el, rnewspost.el
765 773
766* Lisp changes in Emacs 24.1 774* Lisp changes in Emacs 24.1
767 775
776** Code can now use lexical scoping by default instead of dynamic scoping.
777The `lexical-binding' variable lets code use lexical scoping for local
778variables. It is typically set via file-local variables, in which case it
779applies to all the code in that file.
780
781*** `eval' takes a new optional argument `lexical' to choose the new lexical
782binding instead of the old dynamic binding mode.
783
784*** Lexically scoped interpreted functions are represented with a new form
785of function value which looks like (closure ENV ARGS &rest BODY).
786
787*** New macro `letrec' to define recursive local functions.
788
789*** New function `special-variable-p' to check whether a variable is
790declared as dynamically bound.
791
768** pre/post-command-hook are not reset to nil upon error. 792** pre/post-command-hook are not reset to nil upon error.
769Instead, the offending function is removed. 793Instead, the offending function is removed.
770 794
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 32e9c92a255..288199fd702 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,201 @@
12011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Add lexical binding.
4
5 * subr.el (apply-partially): Use new closures rather than CL.
6 (--dolist-tail--, --dotimes-limit--): Don't declare dynamic.
7 (dolist, dotimes): Use slightly different expansion for lexical code.
8 (functionp): Move to C.
9 (letrec): New macro.
10 (with-wrapper-hook): Use it and apply-partially instead of CL.
11 (eval-after-load): Preserve lexical-binding.
12 (save-window-excursion, with-output-to-temp-buffer): Turn them
13 into macros.
14
15 * simple.el (with-wrapper-hook, apply-partially): Move to subr.el.
16
17 * help-fns.el (help-split-fundoc): Return nil if there's nothing else
18 than the arglist.
19 (help-add-fundoc-usage): Don't add `Not documented'.
20 (help-function-arglist): Handle closures, subroutines, and new
21 byte-code-functions.
22 (help-make-usage): Remove leading underscores.
23 (describe-function-1): Handle closures.
24 (describe-variable): Use special-variable-p for completion.
25
26 * files.el (lexical-binding): Declare safe.
27
28 * emacs-lisp/pcase.el: Don't use destructuring-bind.
29 (pcase--memoize): Rename from pcase-memoize. Change weakness.
30 (pcase): Add `let' pattern.
31 Change memoization so it actually works.
32 (pcase-mutually-exclusive-predicates): Add byte-code-function-p.
33 (pcase--u1) <guard, pred>: Fix possible shadowing problem.
34 <let>: New case.
35
36 * emacs-lisp/macroexp.el: Use lexical binding.
37 (macroexpand-all-1): Check obsolete macros. Expand compiler-macros.
38 Don't convert ' to #' without checking that it's indeed quoting
39 a lambda.
40
41 * emacs-lisp/lisp-mode.el (eval-last-sexp-1):
42 Use eval-sexp-add-defvars.
43 (eval-sexp-add-defvars): New fun.
44
45 * emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound.
46
47 * emacs-lisp/eieio.el (byte-compile-file-form-defmethod):
48 Don't autoload.
49 (eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather
50 than the internal `byte-compile-lambda'.
51 (defmethod): Don't hide code under quotes.
52 (eieio-defmethod): New `code' argument.
53
54 * emacs-lisp/eieio-comp.el: Remove.
55
56 * emacs-lisp/edebug.el (edebug-eval-defun)
57 (edebug-eval-top-level-form): Use eval-sexp-add-defvars.
58 (edebug-toggle): Avoid `eval'.
59
60 * emacs-lisp/disass.el (disassemble-internal): Handle new
61 `closure' objects.
62 (disassemble-1): Handle new byte codes.
63
64 * emacs-lisp/cl.el (pushnew): Silence warning.
65
66 * emacs-lisp/cl-macs.el (cl-byte-compile-block)
67 (cl-byte-compile-throw): Remove.
68 (cl-block-wrapper, cl-block-throw): Use compiler-macros instead.
69
70 * emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL
71 closures.
72
73 * emacs-lisp/cconv.el: New file.
74
75 * emacs-lisp/bytecomp.el: Use lexical binding instead of
76 a "bytecomp-" prefix. Macroexpand everything as a separate phase.
77 (byte-compile-initial-macro-environment):
78 Handle declare-function here.
79 (byte-compile--lexical-environment): New var.
80 (byte-stack-ref, byte-stack-set, byte-discardN)
81 (byte-discardN-preserve-tos): New lap codes.
82 (byte-interactive-p): Don't use any more.
83 (byte-compile-push-bytecodes, byte-compile-push-bytecode-const2):
84 New macros.
85 (byte-compile-lapcode): Use them and handle new lap codes.
86 (byte-compile-obsolete): Remove.
87 (byte-compile-arglist-signature): Handle new byte-code arg"lists".
88 (byte-compile-arglist-warn): Check late def of inlinable funs.
89 (byte-compile-cl-warn): Don't silence warnings for compiler-macros
90 since they should have been expanded by now.
91 (byte-compile--outbuffer): Rename from bytecomp-outbuffer.
92 (byte-compile-from-buffer): Remove unused second arg.
93 (byte-compile-preprocess): New function.
94 (byte-compile-toplevel-file-form): New function to distinguish
95 file-form calls from outside from file-form calls from hunk-handlers.
96 (byte-compile-file-form): Simplify.
97 (byte-compile-file-form-defsubst): Remove.
98 (byte-compile-file-form-defmumble): Simplify now that
99 byte-compile-lambda always returns a byte-code-function.
100 (byte-compile): Preprocess.
101 (byte-compile-byte-code-maker, byte-compile-byte-code-unmake):
102 Remove, not used any more.
103 (byte-compile-arglist-vars, byte-compile-make-lambda-lexenv)
104 (byte-compile-make-args-desc): New funs.
105 (byte-compile-lambda): Handle lexical functions. Always return
106 a byte-code-function.
107 (byte-compile-reserved-constants): New var, to make up room for
108 closed-over variables.
109 (byte-compile-constants-vector): Obey it.
110 (byte-compile-top-level): New args `lexenv' and `reserved-csts'.
111 (byte-compile-macroexpand-declare-function): New function.
112 (byte-compile-form): Call byte-compile-unfold-bcf to inline immediate
113 byte-code-functions.
114 (byte-compile-form): Check obsolescence here.
115 (byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions.
116 (byte-compile-variable-ref): Remove.
117 (byte-compile-dynamic-variable-op): New fun.
118 (byte-compile-dynamic-variable-bind, byte-compile-variable-ref)
119 (byte-compile-variable-set): New funs.
120 (byte-compile-discard): Add 2 args.
121 (byte-compile-stack-ref, byte-compile-stack-set)
122 (byte-compile-make-closure, byte-compile-get-closed-var): New funs.
123 (byte-compile-funarg, byte-compile-funarg-2): Remove, handled in
124 macroexpand-all instead.
125 (byte-compile-quote-form): Remove.
126 (byte-compile-push-binding-init, byte-compile-not-lexical-var-p)
127 (byte-compile-bind, byte-compile-unbind): New funs.
128 (byte-compile-let): Handle let* and lexical binding.
129 (byte-compile-let*): Remove.
130 (byte-compile-catch, byte-compile-unwind-protect)
131 (byte-compile-track-mouse, byte-compile-condition-case):
132 Handle a new :fun-body form, used for lexical scoping.
133 (byte-compile-save-window-excursion)
134 (byte-compile-with-output-to-temp-buffer): Remove.
135 (byte-compile-defun): Simplify.
136 (byte-compile-stack-adjustment): New fun.
137 (byte-compile-out): Use it.
138 (byte-compile-refresh-preloaded): Don't reload byte-compiler files.
139
140 * emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile'
141 handler any more.
142
143 * emacs-lisp/byte-opt.el: Use lexical binding.
144 (byte-inline-lapcode): Remove (to bytecomp).
145 (byte-compile-inline-expand): Pay attention to inlining to/from
146 lexically bound code.
147 (byte-compile-unfold-lambda): Don't handle byte-code-functions
148 any more.
149 (byte-optimize-form-code-walker): Don't handle save-window-excursion
150 any more and don't call compiler-macros.
151 (byte-compile-splice-in-already-compiled-code): Remove.
152 (byte-code): Don't inline any more.
153 (disassemble-offset): Receive `bytes' as argument rather than via
154 dynamic scoping.
155 (byte-compile-tag-number): Declare before first use.
156 (byte-decompile-bytecode-1): Handle new byte-codes, don't change
157 `return' even if make-spliceable.
158 (byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove
159 obsolete interactive-p.
160 (byte-optimize-lapcode): Optimize new lap-codes.
161 Don't trip up on new form of `byte-constant' lap code.
162
163 * emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros.
164
165 * emacs-lisp/advice.el (ad-arglist): Use help-function-arglist.
166
167 * custom.el (custom-initialize-default, custom-declare-variable):
168 Use `defvar'.
169
170 * Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS):
171 New variables.
172 (compile-onefile, .el.elc, compile-calc, recompile): Use them.
173 (COMPILE_FIRST): Add macroexp and cconv.
174 * makefile.w32-in: Mirror changes in Makefile.in.
175
176 * vc/cvs-status.el:
177 * vc/diff-mode.el:
178 * vc/log-edit.el:
179 * vc/log-view.el:
180 * vc/smerge-mode.el:
181 * textmodes/bibtex-style.el:
182 * textmodes/css.el:
183 * startup.el:
184 * uniquify.el:
185 * minibuffer.el:
186 * newcomment.el:
187 * reveal.el:
188 * server.el:
189 * mpc.el:
190 * emacs-lisp/smie.el:
191 * doc-view.el:
192 * dired.el:
193 * abbrev.el: Use lexical binding.
194
1952011-04-01 Eli Zaretskii <eliz@gnu.org>
196
197 * info.el (info-display-manual): New function.
198
12011-03-31 Stefan Monnier <monnier@iro.umontreal.ca> 1992011-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
2 200
3 * loadup.el: Load minibuffer after loaddefs, to use define-minor-mode. 201 * loadup.el: Load minibuffer after loaddefs, to use define-minor-mode.
@@ -69,8 +267,8 @@
69 267
702011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change) 2682011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change)
71 269
72 * net/imap.el (imap-shell-open, imap-process-connection-type): Use 270 * net/imap.el (imap-shell-open, imap-process-connection-type):
73 imap-process-connection-type for 'shell' streams as well as 271 Use imap-process-connection-type for 'shell' streams as well as
74 Kerberos, SSL, other subprocesses. 272 Kerberos, SSL, other subprocesses.
75 273
762011-03-28 Leo Liu <sdl.web@gmail.com> 2742011-03-28 Leo Liu <sdl.web@gmail.com>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 06c82181ea1..083f312d613 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -70,12 +70,23 @@ AUTOGENEL = loaddefs.el \
70 cedet/ede/loaddefs.el \ 70 cedet/ede/loaddefs.el \
71 cedet/srecode/loaddefs.el 71 cedet/srecode/loaddefs.el
72 72
73# Value of max-lisp-eval-depth when compiling initially.
74# During bootstrapping the byte-compiler is run interpreted when compiling
75# itself, and uses more stack than usual.
76#
77BIG_STACK_DEPTH = 1200
78BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
79
80BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
81
73# Files to compile before others during a bootstrap. This is done to 82# Files to compile before others during a bootstrap. This is done to
74# speed up the bootstrap process. 83# speed up the bootstrap process.
75 84
76COMPILE_FIRST = \ 85COMPILE_FIRST = \
77 $(lisp)/emacs-lisp/bytecomp.elc \ 86 $(lisp)/emacs-lisp/bytecomp.elc \
78 $(lisp)/emacs-lisp/byte-opt.elc \ 87 $(lisp)/emacs-lisp/byte-opt.elc \
88 $(lisp)/emacs-lisp/macroexp.elc \
89 $(lisp)/emacs-lisp/cconv.elc \
79 $(lisp)/emacs-lisp/autoload.elc 90 $(lisp)/emacs-lisp/autoload.elc
80 91
81# The actual Emacs command run in the targets below. 92# The actual Emacs command run in the targets below.
@@ -195,7 +206,9 @@ compile-onefile:
195 @echo Compiling $(THEFILE) 206 @echo Compiling $(THEFILE)
196 @# Use byte-compile-refresh-preloaded to try and work around some of 207 @# Use byte-compile-refresh-preloaded to try and work around some of
197 @# the most common bootstrapping problems. 208 @# the most common bootstrapping problems.
198 @$(emacs) -l bytecomp -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE) 209 @$(emacs) $(BYTE_COMPILE_FLAGS) \
210 -l bytecomp -f byte-compile-refresh-preloaded \
211 -f batch-byte-compile $(THEFILE)
199 212
200# Files MUST be compiled one by one. If we compile several files in a 213# 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 214# row (i.e., in the same instance of Emacs) we can't make sure that
@@ -210,7 +223,11 @@ compile-onefile:
210# cannot have prerequisites. 223# cannot have prerequisites.
211.el.elc: 224.el.elc:
212 @echo Compiling $< 225 @echo Compiling $<
213 @$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< 226 @# The BIG_STACK_OPTS are only needed to byte-compile the byte-compiler
227 @# files, which is normally done in compile-first, but may also be
228 @# recompiled via this rule.
229 @$(emacs) $(BYTE_COMPILE_FLAGS) \
230 -f batch-byte-compile $<
214 231
215.PHONY: compile-first compile-main compile compile-always 232.PHONY: compile-first compile-main compile compile-always
216 233
@@ -275,7 +292,7 @@ compile-always: doit
275compile-calc: 292compile-calc:
276 for el in $(lisp)/calc/*.el; do \ 293 for el in $(lisp)/calc/*.el; do \
277 echo Compiling $$el; \ 294 echo Compiling $$el; \
278 $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ 295 $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1;\
279 done 296 done
280 297
281# Backup compiled Lisp files in elc.tar.gz. If that file already 298# Backup compiled Lisp files in elc.tar.gz. If that file already
@@ -302,7 +319,8 @@ compile-after-backup: backup-compiled-files compile-always
302# since the environment of later files is affected by definitions in 319# since the environment of later files is affected by definitions in
303# earlier ones. 320# earlier ones.
304recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc 321recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc
305 $(emacs) --eval "(batch-byte-recompile-directory 0)" $(lisp) 322 $(emacs) $(BYTE_COMPILE_FLAGS) \
323 --eval "(batch-byte-recompile-directory 0)" $(lisp)
306 324
307# Update MH-E internal autoloads. These are not to be confused with 325# Update MH-E internal autoloads. These are not to be confused with
308# the autoloads for the MH-E entry points, which are already in loaddefs.el. 326# the autoloads for the MH-E entry points, which are already in loaddefs.el.
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index ddf37aff58f..b2cd2064da2 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -1,4 +1,4 @@
1;;; abbrev.el --- abbrev mode commands for Emacs 1;;; abbrev.el --- abbrev mode commands for Emacs -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
4 4
@@ -814,20 +814,19 @@ Returns the abbrev symbol, if expansion took place."
814 (destructuring-bind (&optional sym name wordstart wordend) 814 (destructuring-bind (&optional sym name wordstart wordend)
815 (abbrev--before-point) 815 (abbrev--before-point)
816 (when sym 816 (when sym
817 (let ((value sym)) 817 (unless (or ;; executing-kbd-macro
818 (unless (or ;; executing-kbd-macro 818 noninteractive
819 noninteractive 819 (window-minibuffer-p (selected-window)))
820 (window-minibuffer-p (selected-window))) 820 ;; Add an undo boundary, in case we are doing this for
821 ;; Add an undo boundary, in case we are doing this for 821 ;; a self-inserting command which has avoided making one so far.
822 ;; a self-inserting command which has avoided making one so far. 822 (undo-boundary))
823 (undo-boundary)) 823 ;; Now sym is the abbrev symbol.
824 ;; Now sym is the abbrev symbol. 824 (setq last-abbrev-text name)
825 (setq last-abbrev-text name) 825 (setq last-abbrev sym)
826 (setq last-abbrev sym) 826 (setq last-abbrev-location wordstart)
827 (setq last-abbrev-location wordstart) 827 ;; If this abbrev has an expansion, delete the abbrev
828 ;; If this abbrev has an expansion, delete the abbrev 828 ;; and insert the expansion.
829 ;; and insert the expansion. 829 (abbrev-insert sym name wordstart wordend)))))
830 (abbrev-insert sym name wordstart wordend))))))
831 830
832(defun unexpand-abbrev () 831(defun unexpand-abbrev ()
833 "Undo the expansion of the last abbrev that expanded. 832 "Undo the expansion of the last abbrev that expanded.
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog
index b6d5cff6b51..fa3f633d1ac 100644
--- a/lisp/cedet/ChangeLog
+++ b/lisp/cedet/ChangeLog
@@ -1,3 +1,8 @@
12011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * semantic/wisent/comp.el (wisent-byte-compile-grammar):
4 Macroexpand before passing to byte-compile-form.
5
12011-01-13 Stefan Monnier <monnier@iro.umontreal.ca> 62011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
2 7
3 * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode. 8 * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode.
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el
index c3243c12923..f92ae88c14e 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -3452,15 +3452,13 @@ where:
3452 (if (wisent-automaton-p grammar) 3452 (if (wisent-automaton-p grammar)
3453 grammar ;; Grammar already compiled just return it 3453 grammar ;; Grammar already compiled just return it
3454 (wisent-with-context compile-grammar 3454 (wisent-with-context compile-grammar
3455 (let* ((gc-cons-threshold 1000000) 3455 (let* ((gc-cons-threshold 1000000))
3456 automaton)
3457 (garbage-collect) 3456 (garbage-collect)
3458 (setq wisent-new-log-flag t) 3457 (setq wisent-new-log-flag t)
3459 ;; Parse input grammar 3458 ;; Parse input grammar
3460 (wisent-parse-grammar grammar start-list) 3459 (wisent-parse-grammar grammar start-list)
3461 ;; Generate the LALR(1) automaton 3460 ;; Generate the LALR(1) automaton
3462 (setq automaton (wisent-parser-automaton)) 3461 (wisent-parser-automaton)))))
3463 automaton))))
3464 3462
3465;;;; -------------------------- 3463;;;; --------------------------
3466;;;; Byte compile input grammar 3464;;;; Byte compile input grammar
@@ -3476,8 +3474,19 @@ Automatically called by the Emacs Lisp byte compiler as a
3476 ;; automaton internal data structure. Then, because the internal 3474 ;; automaton internal data structure. Then, because the internal
3477 ;; data structure contains an obarray, convert it to a lisp form so 3475 ;; data structure contains an obarray, convert it to a lisp form so
3478 ;; it can be byte-compiled. 3476 ;; it can be byte-compiled.
3479 (byte-compile-form (wisent-automaton-lisp-form (eval form)))) 3477 (byte-compile-form
3480 3478 ;; FIXME: we macroexpand here since `byte-compile-form' expects
3479 ;; macroexpanded code, but that's just a workaround: for lexical-binding
3480 ;; the lisp form should have to pass through closure-conversion and
3481 ;; `wisent-byte-compile-grammar' is called much too late for that.
3482 ;; Why isn't this `wisent-automaton-lisp-form' performed at
3483 ;; macroexpansion time? --Stef
3484 (macroexpand-all
3485 (wisent-automaton-lisp-form (eval form)))))
3486
3487;; FIXME: We shouldn't use a `byte-compile' handler. Maybe using a hash-table
3488;; instead of an obarray would work around the problem that obarrays
3489;; aren't printable. Then (put 'wisent-compile-grammar 'side-effect-free t).
3481(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar) 3490(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar)
3482 3491
3483(defun wisent-automaton-lisp-form (automaton) 3492(defun wisent-automaton-lisp-form (automaton)
diff --git a/lisp/custom.el b/lisp/custom.el
index e837c501438..5b5592698d8 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -55,11 +55,9 @@ Otherwise, if symbol has a `saved-value' property, it will evaluate
55the car of that and use it as the default binding for symbol. 55the car of that and use it as the default binding for symbol.
56Otherwise, VALUE will be evaluated and used as the default binding for 56Otherwise, VALUE will be evaluated and used as the default binding for
57symbol." 57symbol."
58 (unless (default-boundp symbol) 58 (eval `(defvar ,symbol ,(if (get symbol 'saved-value)
59 ;; Use the saved value if it exists, otherwise the standard setting. 59 (car (get symbol 'saved-value))
60 (set-default symbol (eval (if (get symbol 'saved-value) 60 value))))
61 (car (get symbol 'saved-value))
62 value)))))
63 61
64(defun custom-initialize-set (symbol value) 62(defun custom-initialize-set (symbol value)
65 "Initialize SYMBOL based on VALUE. 63 "Initialize SYMBOL based on VALUE.
@@ -81,15 +79,15 @@ The value is either the symbol's current value
81 \(as obtained using the `:get' function), if any, 79 \(as obtained using the `:get' function), if any,
82or the value in the symbol's `saved-value' property if any, 80or the value in the symbol's `saved-value' property if any,
83or (last of all) VALUE." 81or (last of all) VALUE."
84 (funcall (or (get symbol 'custom-set) 'set-default) 82 (funcall (or (get symbol 'custom-set) 'set-default)
85 symbol 83 symbol
86 (cond ((default-boundp symbol) 84 (cond ((default-boundp symbol)
87 (funcall (or (get symbol 'custom-get) 'default-value) 85 (funcall (or (get symbol 'custom-get) 'default-value)
88 symbol)) 86 symbol))
89 ((get symbol 'saved-value) 87 ((get symbol 'saved-value)
90 (eval (car (get symbol 'saved-value)))) 88 (eval (car (get symbol 'saved-value))))
91 (t 89 (t
92 (eval value))))) 90 (eval value)))))
93 91
94(defun custom-initialize-changed (symbol value) 92(defun custom-initialize-changed (symbol value)
95 "Initialize SYMBOL with VALUE. 93 "Initialize SYMBOL with VALUE.
@@ -142,10 +140,8 @@ set to nil, as the value is no longer rogue."
142 ;; Maybe this option was rogue in an earlier version. It no longer is. 140 ;; Maybe this option was rogue in an earlier version. It no longer is.
143 (when (get symbol 'force-value) 141 (when (get symbol 'force-value)
144 (put symbol 'force-value nil)) 142 (put symbol 'force-value nil))
145 (when doc 143 (if (keywordp doc)
146 (if (keywordp doc) 144 (error "Doc string is missing"))
147 (error "Doc string is missing")
148 (put symbol 'variable-documentation doc)))
149 (let ((initialize 'custom-initialize-reset) 145 (let ((initialize 'custom-initialize-reset)
150 (requests nil)) 146 (requests nil))
151 (unless (memq :group args) 147 (unless (memq :group args)
@@ -189,6 +185,13 @@ set to nil, as the value is no longer rogue."
189 ;; Do the actual initialization. 185 ;; Do the actual initialization.
190 (unless custom-dont-initialize 186 (unless custom-dont-initialize
191 (funcall initialize symbol default))) 187 (funcall initialize symbol default)))
188 ;; Use defvar to set the docstring as well as the special-variable-p flag.
189 ;; FIXME: We should reproduce more of `defvar's behavior, such as the warning
190 ;; when the var is currently let-bound.
191 (if (not (default-boundp symbol))
192 ;; Don't use defvar to avoid setting a default-value when undesired.
193 (when doc (put symbol 'variable-documentation doc))
194 (eval `(defvar ,symbol nil ,@(when doc (list doc)))))
192 (push symbol current-load-list) 195 (push symbol current-load-list)
193 (run-hooks 'custom-define-hook) 196 (run-hooks 'custom-define-hook)
194 symbol) 197 symbol)
diff --git a/lisp/dired.el b/lisp/dired.el
index 22470ea61e6..d72e0aad55f 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -1,4 +1,4 @@
1;;; dired.el --- directory-browsing commands 1;;; dired.el --- directory-browsing commands -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1985-1986, 1992-1997, 2000-2011 3;; Copyright (C) 1985-1986, 1992-1997, 2000-2011
4;; Free Software Foundation, Inc. 4;; Free Software Foundation, Inc.
@@ -1181,7 +1181,7 @@ If HDR is non-nil, insert a header line with the directory name."
1181 1181
1182;; Reverting a dired buffer 1182;; Reverting a dired buffer
1183 1183
1184(defun dired-revert (&optional arg noconfirm) 1184(defun dired-revert (&optional _arg _noconfirm)
1185 "Reread the dired buffer. 1185 "Reread the dired buffer.
1186Must also be called after `dired-actual-switches' have changed. 1186Must also be called after `dired-actual-switches' have changed.
1187Should not fail even on completely garbaged buffers. 1187Should not fail even on completely garbaged buffers.
@@ -2143,7 +2143,7 @@ Optional arg GLOBAL means to replace all matches."
2143 ;; dired-get-filename. 2143 ;; dired-get-filename.
2144 (concat (or dir default-directory) file)) 2144 (concat (or dir default-directory) file))
2145 2145
2146(defun dired-make-relative (file &optional dir ignore) 2146(defun dired-make-relative (file &optional dir _ignore)
2147 "Convert FILE (an absolute file name) to a name relative to DIR. 2147 "Convert FILE (an absolute file name) to a name relative to DIR.
2148If this is impossible, return FILE unchanged. 2148If this is impossible, return FILE unchanged.
2149DIR must be a directory name, not a file name." 2149DIR must be a directory name, not a file name."
@@ -3233,7 +3233,7 @@ Type \\[help-command] at that time for help."
3233 (interactive "cRemove marks (RET means all): \nP") 3233 (interactive "cRemove marks (RET means all): \nP")
3234 (save-excursion 3234 (save-excursion
3235 (let* ((count 0) 3235 (let* ((count 0)
3236 (inhibit-read-only t) case-fold-search query 3236 (inhibit-read-only t) case-fold-search
3237 (string (format "\n%c" mark)) 3237 (string (format "\n%c" mark))
3238 (help-form "\ 3238 (help-form "\
3239Type SPC or `y' to unmark one file, DEL or `n' to skip to next, 3239Type SPC or `y' to unmark one file, DEL or `n' to skip to next,
@@ -3508,6 +3508,8 @@ Anything else means ask for each directory."
3508(declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist)) 3508(declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist))
3509(declare-function dnd-get-local-file-uri "dnd" (uri)) 3509(declare-function dnd-get-local-file-uri "dnd" (uri))
3510 3510
3511(defvar dired-overwrite-confirmed) ;Defined in dired-aux.
3512
3511(defun dired-dnd-handle-local-file (uri action) 3513(defun dired-dnd-handle-local-file (uri action)
3512 "Copy, move or link a file to the dired directory. 3514 "Copy, move or link a file to the dired directory.
3513URI is the file to handle, ACTION is one of copy, move, link or ask. 3515URI is the file to handle, ACTION is one of copy, move, link or ask.
@@ -3569,38 +3571,38 @@ Ask means pop up a menu for the user to select one of copy, move or link."
3569 3571
3570(eval-when-compile (require 'desktop)) 3572(eval-when-compile (require 'desktop))
3571 3573
3572(defun dired-desktop-buffer-misc-data (desktop-dirname) 3574(defun dired-desktop-buffer-misc-data (dirname)
3573 "Auxiliary information to be saved in desktop file." 3575 "Auxiliary information to be saved in desktop file."
3574 (cons 3576 (cons
3575 ;; Value of `dired-directory'. 3577 ;; Value of `dired-directory'.
3576 (if (consp dired-directory) 3578 (if (consp dired-directory)
3577 ;; Directory name followed by list of files. 3579 ;; Directory name followed by list of files.
3578 (cons (desktop-file-name (car dired-directory) desktop-dirname) 3580 (cons (desktop-file-name (car dired-directory) dirname)
3579 (cdr dired-directory)) 3581 (cdr dired-directory))
3580 ;; Directory name, optionally with shell wildcard. 3582 ;; Directory name, optionally with shell wildcard.
3581 (desktop-file-name dired-directory desktop-dirname)) 3583 (desktop-file-name dired-directory dirname))
3582 ;; Subdirectories in `dired-subdir-alist'. 3584 ;; Subdirectories in `dired-subdir-alist'.
3583 (cdr 3585 (cdr
3584 (nreverse 3586 (nreverse
3585 (mapcar 3587 (mapcar
3586 (function (lambda (f) (desktop-file-name (car f) desktop-dirname))) 3588 (function (lambda (f) (desktop-file-name (car f) dirname)))
3587 dired-subdir-alist))))) 3589 dired-subdir-alist)))))
3588 3590
3589(defun dired-restore-desktop-buffer (desktop-buffer-file-name 3591(defun dired-restore-desktop-buffer (_file-name
3590 desktop-buffer-name 3592 _buffer-name
3591 desktop-buffer-misc) 3593 misc-data)
3592 "Restore a dired buffer specified in a desktop file." 3594 "Restore a dired buffer specified in a desktop file."
3593 ;; First element of `desktop-buffer-misc' is the value of `dired-directory'. 3595 ;; First element of `misc-data' is the value of `dired-directory'.
3594 ;; This value is a directory name, optionally with shell wildcard or 3596 ;; This value is a directory name, optionally with shell wildcard or
3595 ;; a directory name followed by list of files. 3597 ;; a directory name followed by list of files.
3596 (let* ((dired-dir (car desktop-buffer-misc)) 3598 (let* ((dired-dir (car misc-data))
3597 (dir (if (consp dired-dir) (car dired-dir) dired-dir))) 3599 (dir (if (consp dired-dir) (car dired-dir) dired-dir)))
3598 (if (file-directory-p (file-name-directory dir)) 3600 (if (file-directory-p (file-name-directory dir))
3599 (progn 3601 (progn
3600 (dired dired-dir) 3602 (dired dired-dir)
3601 ;; The following elements of `desktop-buffer-misc' are the keys 3603 ;; The following elements of `misc-data' are the keys
3602 ;; from `dired-subdir-alist'. 3604 ;; from `dired-subdir-alist'.
3603 (mapc 'dired-maybe-insert-subdir (cdr desktop-buffer-misc)) 3605 (mapc 'dired-maybe-insert-subdir (cdr misc-data))
3604 (current-buffer)) 3606 (current-buffer))
3605 (message "Desktop: Directory %s no longer exists." dir) 3607 (message "Desktop: Directory %s no longer exists." dir)
3606 (when desktop-missing-file-warning (sit-for 1)) 3608 (when desktop-missing-file-warning (sit-for 1))
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index c67205fd52b..7bead624cc7 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -1,4 +1,5 @@
1;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs 1;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*-
2
2 3
3;; Copyright (C) 2007-2011 Free Software Foundation, Inc. 4;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
4;; 5;;
@@ -155,7 +156,7 @@
155 156
156(defcustom doc-view-ghostscript-options 157(defcustom doc-view-ghostscript-options
157 '("-dSAFER" ;; Avoid security problems when rendering files from untrusted 158 '("-dSAFER" ;; Avoid security problems when rendering files from untrusted
158 ;; sources. 159 ;; sources.
159 "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" 160 "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4"
160 "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") 161 "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET")
161 "A list of options to give to ghostscript." 162 "A list of options to give to ghostscript."
@@ -442,9 +443,7 @@ Can be `dvi', `pdf', or `ps'.")
442 doc-view-current-converter-processes) 443 doc-view-current-converter-processes)
443 ;; The PNG file hasn't been generated yet. 444 ;; The PNG file hasn't been generated yet.
444 (doc-view-pdf->png-1 doc-view-buffer-file-name file page 445 (doc-view-pdf->png-1 doc-view-buffer-file-name file page
445 (lexical-let ((page page) 446 (let ((win (selected-window)))
446 (win (selected-window))
447 (file file))
448 (lambda () 447 (lambda ()
449 (and (eq (current-buffer) (window-buffer win)) 448 (and (eq (current-buffer) (window-buffer win))
450 ;; If we changed page in the mean 449 ;; If we changed page in the mean
@@ -453,7 +452,7 @@ Can be `dvi', `pdf', or `ps'.")
453 ;; Make sure we don't infloop. 452 ;; Make sure we don't infloop.
454 (file-readable-p file) 453 (file-readable-p file)
455 (with-selected-window win 454 (with-selected-window win
456 (doc-view-goto-page page)))))))) 455 (doc-view-goto-page page))))))))
457 (overlay-put (doc-view-current-overlay) 456 (overlay-put (doc-view-current-overlay)
458 'help-echo (doc-view-current-info)))) 457 'help-echo (doc-view-current-info))))
459 458
@@ -713,8 +712,8 @@ Should be invoked when the cached images aren't up-to-date."
713 (if (and doc-view-dvipdf-program 712 (if (and doc-view-dvipdf-program
714 (executable-find doc-view-dvipdf-program)) 713 (executable-find doc-view-dvipdf-program))
715 (doc-view-start-process "dvi->pdf" doc-view-dvipdf-program 714 (doc-view-start-process "dvi->pdf" doc-view-dvipdf-program
716 (list dvi pdf) 715 (list dvi pdf)
717 callback) 716 callback)
718 (doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program 717 (doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program
719 (list "-o" pdf dvi) 718 (list "-o" pdf dvi)
720 callback))) 719 callback)))
@@ -735,7 +734,7 @@ is named like ODF with the extension turned to pdf."
735 (list (format "-r%d" (round doc-view-resolution)) 734 (list (format "-r%d" (round doc-view-resolution))
736 (concat "-sOutputFile=" png) 735 (concat "-sOutputFile=" png)
737 pdf-ps)) 736 pdf-ps))
738 (lexical-let ((resolution doc-view-resolution)) 737 (let ((resolution doc-view-resolution))
739 (lambda () 738 (lambda ()
740 ;; Only create the resolution file when it's all done, so it also 739 ;; Only create the resolution file when it's all done, so it also
741 ;; serves as a witness that the conversion is complete. 740 ;; serves as a witness that the conversion is complete.
@@ -780,7 +779,7 @@ Start by converting PAGES, and then the rest."
780 ;; (almost) consecutive, but since in 99% of the cases, there'll be only 779 ;; (almost) consecutive, but since in 99% of the cases, there'll be only
781 ;; a single page anyway, and of the remaining 1%, few cases will have 780 ;; a single page anyway, and of the remaining 1%, few cases will have
782 ;; consecutive pages, it's not worth the trouble. 781 ;; consecutive pages, it's not worth the trouble.
783 (lexical-let ((pdf pdf) (png png) (rest (cdr pages))) 782 (let ((rest (cdr pages)))
784 (doc-view-pdf->png-1 783 (doc-view-pdf->png-1
785 pdf (format png (car pages)) (car pages) 784 pdf (format png (car pages)) (car pages)
786 (lambda () 785 (lambda ()
@@ -793,8 +792,8 @@ Start by converting PAGES, and then the rest."
793 ;; not sufficient. 792 ;; not sufficient.
794 (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) 793 (dolist (win (get-buffer-window-list (current-buffer) nil 'visible))
795 (with-selected-window win 794 (with-selected-window win
796 (when (stringp (get-char-property (point-min) 'display)) 795 (when (stringp (get-char-property (point-min) 'display))
797 (doc-view-goto-page (doc-view-current-page))))) 796 (doc-view-goto-page (doc-view-current-page)))))
798 ;; Convert the rest of the pages. 797 ;; Convert the rest of the pages.
799 (doc-view-pdf/ps->png pdf png))))))) 798 (doc-view-pdf/ps->png pdf png)))))))
800 799
@@ -816,10 +815,8 @@ Start by converting PAGES, and then the rest."
816 (ps 815 (ps
817 ;; Doc is a PS, so convert it to PDF (which will be converted to 816 ;; Doc is a PS, so convert it to PDF (which will be converted to
818 ;; TXT thereafter). 817 ;; TXT thereafter).
819 (lexical-let ((pdf (expand-file-name "doc.pdf" 818 (let ((pdf (expand-file-name "doc.pdf"
820 (doc-view-current-cache-dir))) 819 (doc-view-current-cache-dir))))
821 (txt txt)
822 (callback callback))
823 (doc-view-ps->pdf doc-view-buffer-file-name pdf 820 (doc-view-ps->pdf doc-view-buffer-file-name pdf
824 (lambda () (doc-view-pdf->txt pdf txt callback))))) 821 (lambda () (doc-view-pdf->txt pdf txt callback)))))
825 (dvi 822 (dvi
@@ -873,9 +870,7 @@ Those files are saved in the directory given by the function
873 (dvi 870 (dvi
874 ;; DVI files have to be converted to PDF before Ghostscript can process 871 ;; DVI files have to be converted to PDF before Ghostscript can process
875 ;; it. 872 ;; it.
876 (lexical-let 873 (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)))
877 ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))
878 (png-file png-file))
879 (doc-view-dvi->pdf doc-view-buffer-file-name pdf 874 (doc-view-dvi->pdf doc-view-buffer-file-name pdf
880 (lambda () (doc-view-pdf/ps->png pdf png-file))))) 875 (lambda () (doc-view-pdf/ps->png pdf png-file)))))
881 (odf 876 (odf
@@ -1026,8 +1021,8 @@ have the page we want to view."
1026 (and (not (member pagefile prev-pages)) 1021 (and (not (member pagefile prev-pages))
1027 (member pagefile doc-view-current-files))) 1022 (member pagefile doc-view-current-files)))
1028 (with-selected-window win 1023 (with-selected-window win
1029 (assert (eq (current-buffer) buffer)) 1024 (assert (eq (current-buffer) buffer))
1030 (doc-view-goto-page page)))))))) 1025 (doc-view-goto-page page))))))))
1031 1026
1032(defun doc-view-buffer-message () 1027(defun doc-view-buffer-message ()
1033 ;; Only show this message initially, not when refreshing the buffer (in which 1028 ;; Only show this message initially, not when refreshing the buffer (in which
@@ -1470,9 +1465,9 @@ See the command `doc-view-mode' for more information on this mode."
1470 (when (not (eq major-mode 'doc-view-mode)) 1465 (when (not (eq major-mode 'doc-view-mode))
1471 (doc-view-toggle-display)) 1466 (doc-view-toggle-display))
1472 (with-selected-window 1467 (with-selected-window
1473 (or (get-buffer-window (current-buffer) 0) 1468 (or (get-buffer-window (current-buffer) 0)
1474 (selected-window)) 1469 (selected-window))
1475 (doc-view-goto-page page))))) 1470 (doc-view-goto-page page)))))
1476 1471
1477 1472
1478(provide 'doc-view) 1473(provide 'doc-view)
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 915a726ae11..39ea97aa98e 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2535,17 +2535,11 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
2535 "Return the argument list of DEFINITION. 2535 "Return the argument list of DEFINITION.
2536If DEFINITION could be from a subr then its NAME should be 2536If DEFINITION could be from a subr then its NAME should be
2537supplied to make subr arglist lookup more efficient." 2537supplied to make subr arglist lookup more efficient."
2538 (cond ((ad-compiled-p definition) 2538 (require 'help-fns)
2539 (aref (ad-compiled-code definition) 0)) 2539 (cond
2540 ((consp definition) 2540 ((or (ad-macro-p definition) (ad-advice-p definition))
2541 (car (cdr (ad-lambda-expression definition)))) 2541 (help-function-arglist (cdr definition)))
2542 ((ad-subr-p definition) 2542 (t (help-function-arglist definition))))
2543 (if name
2544 (ad-subr-arglist name)
2545 ;; otherwise get it from its printed representation:
2546 (setq name (format "%s" definition))
2547 (string-match "^#<subr \\([^>]+\\)>$" name)
2548 (ad-subr-arglist (intern (match-string 1 name)))))))
2549 2543
2550;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish 2544;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
2551;; a defined empty arglist `(nil)' from an undefined arglist: 2545;; a defined empty arglist `(nil)' from an undefined arglist:
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index d6e7ee9e3cb..5a5d6b88a2d 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -137,7 +137,7 @@ or macro definition or a defcustom)."
137 ;; Special case to autoload some of the macro's declarations. 137 ;; Special case to autoload some of the macro's declarations.
138 (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) 138 (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form))
139 (exps '())) 139 (exps '()))
140 (when (eq (car decls) 'declare) 140 (when (eq (car-safe decls) 'declare)
141 ;; FIXME: We'd like to reuse macro-declaration-function, 141 ;; FIXME: We'd like to reuse macro-declaration-function,
142 ;; but we can't since it doesn't return anything. 142 ;; but we can't since it doesn't return anything.
143 (dolist (decl decls) 143 (dolist (decl decls)
@@ -471,7 +471,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
471 (marker-buffer output-start))) 471 (marker-buffer output-start)))
472 (autoload-print-form autoload))) 472 (autoload-print-form autoload)))
473 (error 473 (error
474 (message "Error in %s: %S" file err))) 474 (message "Autoload cookie error in %s:%s %S"
475 file (count-lines (point-min) (point)) err)))
475 476
476 ;; Copy the rest of the line to the output. 477 ;; Copy the rest of the line to the output.
477 (princ (buffer-substring 478 (princ (buffer-substring
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 0f4018dc8da..548fcd133df 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1,4 +1,4 @@
1;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler 1;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc.
4 4
@@ -186,8 +186,10 @@
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 ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
190 (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) 190 ;; But the "old disassembler" is *really* ancient by now.
191 ;; (if (aref byte-code-vector 0)
192 ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
191 (byte-compile-log-1 193 (byte-compile-log-1
192 (apply 'format format 194 (apply 'format format
193 (let (c a) 195 (let (c a)
@@ -242,58 +244,72 @@
242 sexp))) 244 sexp)))
243 (cdr form)))) 245 (cdr form))))
244 246
245
246;; Splice the given lap code into the current instruction stream.
247;; If it has any labels in it, you're responsible for making sure there
248;; are no collisions, and that byte-compile-tag-number is reasonable
249;; after this is spliced in. The provided list is destroyed.
250(defun byte-inline-lapcode (lap)
251 (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
252
253(defun byte-compile-inline-expand (form) 247(defun byte-compile-inline-expand (form)
254 (let* ((name (car form)) 248 (let* ((name (car form))
255 (fn (or (cdr (assq name byte-compile-function-environment)) 249 (localfn (cdr (assq name byte-compile-function-environment)))
256 (and (fboundp name) (symbol-function name))))) 250 (fn (or localfn (and (fboundp name) (symbol-function name)))))
257 (if (null fn) 251 (when (and (consp fn) (eq (car fn) 'autoload))
258 (progn 252 (load (nth 1 fn))
259 (byte-compile-warn "attempt to inline `%s' before it was defined" 253 (setq fn (or (and (fboundp name) (symbol-function name))
260 name) 254 (cdr (assq name byte-compile-function-environment)))))
261 form) 255 (pcase fn
262 ;; else 256 (`nil
263 (when (and (consp fn) (eq (car fn) 'autoload)) 257 (byte-compile-warn "attempt to inline `%s' before it was defined"
264 (load (nth 1 fn)) 258 name)
265 (setq fn (or (and (fboundp name) (symbol-function name)) 259 form)
266 (cdr (assq name byte-compile-function-environment))))) 260 (`(autoload . ,_)
267 (if (and (consp fn) (eq (car fn) 'autoload)) 261 (error "File `%s' didn't define `%s'" (nth 1 fn) name))
268 (error "File `%s' didn't define `%s'" (nth 1 fn) name)) 262 ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
269 (if (and (symbolp fn) (not (eq fn t))) 263 (byte-compile-inline-expand (cons fn (cdr form))))
270 (byte-compile-inline-expand (cons fn (cdr form))) 264 ((pred byte-code-function-p)
271 (if (byte-code-function-p fn) 265 ;; (message "Inlining byte-code for %S!" name)
272 (let (string) 266 ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
273 (fetch-bytecode fn) 267 `(,fn ,@(cdr form)))
274 (setq string (aref fn 1)) 268 ((or (and `(lambda ,args . ,body) (let env nil))
275 ;; Isn't it an error for `string' not to be unibyte?? --stef 269 `(closure ,env ,args . ,body))
276 (if (fboundp 'string-as-unibyte) 270 (if (not (or (eq fn localfn) ;From the same file => same mode.
277 (setq string (string-as-unibyte string))) 271 (eq (not lexical-binding) (not env)))) ;Same mode.
278 ;; `byte-compile-splice-in-already-compiled-code' 272 ;; While byte-compile-unfold-bcf can inline dynbind byte-code into
279 ;; takes care of inlining the body. 273 ;; letbind byte-code (or any other combination for that matter), we
280 (cons `(lambda ,(aref fn 0) 274 ;; can only inline dynbind source into dynbind source or letbind
281 (byte-code ,string ,(aref fn 2) ,(aref fn 3))) 275 ;; source into letbind source.
282 (cdr form))) 276 ;; FIXME: we could of course byte-compile the inlined function
283 (if (eq (car-safe fn) 'lambda) 277 ;; first, and then inline its byte-code.
284 (cons fn (cdr form)) 278 form
285 ;; Give up on inlining. 279 (let ((renv ()))
286 form)))))) 280 ;; Turn the function's closed vars (if any) into local let bindings.
281 (dolist (binding env)
282 (cond
283 ((consp binding)
284 ;; We check shadowing by the args, so that the `let' can be
285 ;; moved within the lambda, which can then be unfolded.
286 ;; FIXME: Some of those bindings might be unused in `body'.
287 (unless (memq (car binding) args) ;Shadowed.
288 (push `(,(car binding) ',(cdr binding)) renv)))
289 ((eq binding t))
290 (t (push `(defvar ,binding) body))))
291 (let ((newfn (byte-compile-preprocess
292 (if (null renv)
293 `(lambda ,args ,@body)
294 `(lambda ,args (let ,(nreverse renv) ,@body))))))
295 (if (eq (car-safe newfn) 'function)
296 (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
297 (byte-compile-log-warning
298 (format "Inlining closure %S failed" name))
299 form)))))
300
301 (t ;; Give up on inlining.
302 form))))
287 303
288;; ((lambda ...) ...) 304;; ((lambda ...) ...)
289(defun byte-compile-unfold-lambda (form &optional name) 305(defun byte-compile-unfold-lambda (form &optional name)
306 ;; In lexical-binding mode, let and functions don't bind vars in the same way
307 ;; (let obey special-variable-p, but functions don't). But luckily, this
308 ;; doesn't matter here, because function's behavior is underspecified so it
309 ;; can safely be turned into a `let', even though the reverse is not true.
290 (or name (setq name "anonymous lambda")) 310 (or name (setq name "anonymous lambda"))
291 (let ((lambda (car form)) 311 (let ((lambda (car form))
292 (values (cdr form))) 312 (values (cdr form)))
293 (if (byte-code-function-p lambda)
294 (setq lambda (list 'lambda (aref lambda 0)
295 (list 'byte-code (aref lambda 1)
296 (aref lambda 2) (aref lambda 3)))))
297 (let ((arglist (nth 1 lambda)) 313 (let ((arglist (nth 1 lambda))
298 (body (cdr (cdr lambda))) 314 (body (cdr (cdr lambda)))
299 optionalp restp 315 optionalp restp
@@ -302,6 +318,7 @@
302 (setq body (cdr body))) 318 (setq body (cdr body)))
303 (if (and (consp (car body)) (eq 'interactive (car (car body)))) 319 (if (and (consp (car body)) (eq 'interactive (car (car body))))
304 (setq body (cdr body))) 320 (setq body (cdr body)))
321 ;; FIXME: The checks below do not belong in an optimization phase.
305 (while arglist 322 (while arglist
306 (cond ((eq (car arglist) '&optional) 323 (cond ((eq (car arglist) '&optional)
307 ;; ok, I'll let this slide because funcall_lambda() does... 324 ;; ok, I'll let this slide because funcall_lambda() does...
@@ -379,8 +396,7 @@
379 (and (nth 1 form) 396 (and (nth 1 form)
380 (not for-effect) 397 (not for-effect)
381 form)) 398 form))
382 ((or (byte-code-function-p fn) 399 ((eq 'lambda (car-safe fn))
383 (eq 'lambda (car-safe fn)))
384 (let ((newform (byte-compile-unfold-lambda form))) 400 (let ((newform (byte-compile-unfold-lambda form)))
385 (if (eq newform form) 401 (if (eq newform form)
386 ;; Some error occurred, avoid infinite recursion 402 ;; Some error occurred, avoid infinite recursion
@@ -455,8 +471,8 @@
455 (byte-optimize-form (nth 2 form) for-effect) 471 (byte-optimize-form (nth 2 form) for-effect)
456 (byte-optimize-body (nthcdr 3 form) for-effect))))) 472 (byte-optimize-body (nthcdr 3 form) for-effect)))))
457 473
458 ((memq fn '(and or)) ; remember, and/or are control structures. 474 ((memq fn '(and or)) ; Remember, and/or are control structures.
459 ;; take forms off the back until we can't any more. 475 ;; Take forms off the back until we can't any more.
460 ;; In the future it could conceivably be a problem that the 476 ;; In the future it could conceivably be a problem that the
461 ;; subexpressions of these forms are optimized in the reverse 477 ;; subexpressions of these forms are optimized in the reverse
462 ;; order, but it's ok for now. 478 ;; order, but it's ok for now.
@@ -471,7 +487,8 @@
471 (byte-compile-log 487 (byte-compile-log
472 " all subforms of %s called for effect; deleted" form)) 488 " all subforms of %s called for effect; deleted" form))
473 (and backwards 489 (and backwards
474 (cons fn (nreverse (mapcar 'byte-optimize-form backwards))))) 490 (cons fn (nreverse (mapcar 'byte-optimize-form
491 backwards)))))
475 (cons fn (mapcar 'byte-optimize-form (cdr form))))) 492 (cons fn (mapcar 'byte-optimize-form (cdr form)))))
476 493
477 ((eq fn 'interactive) 494 ((eq fn 'interactive)
@@ -479,8 +496,7 @@
479 (prin1-to-string form)) 496 (prin1-to-string form))
480 nil) 497 nil)
481 498
482 ((memq fn '(defun defmacro function 499 ((memq fn '(defun defmacro function condition-case))
483 condition-case save-window-excursion))
484 ;; These forms are compiled as constants or by breaking out 500 ;; These forms are compiled as constants or by breaking out
485 ;; all the subexpressions and compiling them separately. 501 ;; all the subexpressions and compiling them separately.
486 form) 502 form)
@@ -511,23 +527,11 @@
511 ;; However, don't actually bother calling `ignore'. 527 ;; However, don't actually bother calling `ignore'.
512 `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) 528 `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
513 529
514 ;; If optimization is on, this is the only place that macros are 530 ;; Neeeded as long as we run byte-optimize-form after cconv.
515 ;; expanded. If optimization is off, then macroexpansion happens 531 ((eq fn 'internal-make-closure) form)
516 ;; in byte-compile-form. Otherwise, the macros are already expanded 532
517 ;; by the time that is reached. 533 ((byte-code-function-p fn)
518 ((not (eq form 534 (cons fn (mapcar #'byte-optimize-form (cdr form))))
519 (setq form (macroexpand form
520 byte-compile-macro-environment))))
521 (byte-optimize-form form for-effect))
522
523 ;; Support compiler macros as in cl.el.
524 ((and (fboundp 'compiler-macroexpand)
525 (symbolp (car-safe form))
526 (get (car-safe form) 'cl-compiler-macro)
527 (not (eq form
528 (with-no-warnings
529 (setq form (compiler-macroexpand form))))))
530 (byte-optimize-form form for-effect))
531 535
532 ((not (symbolp fn)) 536 ((not (symbolp fn))
533 (byte-compile-warn "`%s' is a malformed function" 537 (byte-compile-warn "`%s' is a malformed function"
@@ -605,7 +609,7 @@
605 609
606 610
607(defun byte-optimize-body (forms all-for-effect) 611(defun byte-optimize-body (forms all-for-effect)
608 ;; optimize the cdr of a progn or implicit progn; all forms is a list of 612 ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
609 ;; forms, all but the last of which are optimized with the assumption that 613 ;; forms, all but the last of which are optimized with the assumption that
610 ;; they are being called for effect. the last is for-effect as well if 614 ;; they are being called for effect. the last is for-effect as well if
611 ;; all-for-effect is true. returns a new list of forms. 615 ;; all-for-effect is true. returns a new list of forms.
@@ -1085,7 +1089,7 @@
1085 (let ((fn (nth 1 form))) 1089 (let ((fn (nth 1 form)))
1086 (if (memq (car-safe fn) '(quote function)) 1090 (if (memq (car-safe fn) '(quote function))
1087 (cons (nth 1 fn) (cdr (cdr form))) 1091 (cons (nth 1 fn) (cdr (cdr form)))
1088 form))) 1092 form)))
1089 1093
1090(defun byte-optimize-apply (form) 1094(defun byte-optimize-apply (form)
1091 ;; If the last arg is a literal constant, turn this into a funcall. 1095 ;; If the last arg is a literal constant, turn this into a funcall.
@@ -1291,63 +1295,51 @@
1291 (put (car pure-fns) 'pure t) 1295 (put (car pure-fns) 'pure t)
1292 (setq pure-fns (cdr pure-fns))) 1296 (setq pure-fns (cdr pure-fns)))
1293 nil) 1297 nil)
1294
1295(defun byte-compile-splice-in-already-compiled-code (form)
1296 ;; form is (byte-code "..." [...] n)
1297 (if (not (memq byte-optimize '(t lap)))
1298 (byte-compile-normal-call form)
1299 (byte-inline-lapcode
1300 (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
1301 (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
1302 byte-compile-maxdepth))
1303 (setq byte-compile-depth (1+ byte-compile-depth))))
1304
1305(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
1306
1307 1298
1308(defconst byte-constref-ops 1299(defconst byte-constref-ops
1309 '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) 1300 '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
1310 1301
1302;; Used and set dynamically in byte-decompile-bytecode-1.
1303(defvar bytedecomp-op)
1304(defvar bytedecomp-ptr)
1305
1311;; This function extracts the bitfields from variable-length opcodes. 1306;; This function extracts the bitfields from variable-length opcodes.
1312;; Originally defined in disass.el (which no longer uses it.) 1307;; Originally defined in disass.el (which no longer uses it.)
1313 1308(defun disassemble-offset (bytes)
1314(defun disassemble-offset ()
1315 "Don't call this!" 1309 "Don't call this!"
1316 ;; fetch and return the offset for the current opcode. 1310 ;; Fetch and return the offset for the current opcode.
1317 ;; return nil if this opcode has no offset 1311 ;; Return nil if this opcode has no offset.
1318 ;; Used and set dynamically in byte-decompile-bytecode-1.
1319 (defvar bytedecomp-op)
1320 (defvar bytedecomp-ptr)
1321 (defvar bytedecomp-bytes)
1322 (cond ((< bytedecomp-op byte-nth) 1312 (cond ((< bytedecomp-op byte-nth)
1323 (let ((tem (logand bytedecomp-op 7))) 1313 (let ((tem (logand bytedecomp-op 7)))
1324 (setq bytedecomp-op (logand bytedecomp-op 248)) 1314 (setq bytedecomp-op (logand bytedecomp-op 248))
1325 (cond ((eq tem 6) 1315 (cond ((eq tem 6)
1326 ;; Offset in next byte. 1316 ;; Offset in next byte.
1327 (setq bytedecomp-ptr (1+ bytedecomp-ptr)) 1317 (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1328 (aref bytedecomp-bytes bytedecomp-ptr)) 1318 (aref bytes bytedecomp-ptr))
1329 ((eq tem 7) 1319 ((eq tem 7)
1330 ;; Offset in next 2 bytes. 1320 ;; Offset in next 2 bytes.
1331 (setq bytedecomp-ptr (1+ bytedecomp-ptr)) 1321 (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1332 (+ (aref bytedecomp-bytes bytedecomp-ptr) 1322 (+ (aref bytes bytedecomp-ptr)
1333 (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) 1323 (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1334 (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) 1324 (lsh (aref bytes bytedecomp-ptr) 8))))
1335 (t tem)))) ;offset was in opcode 1325 (t tem)))) ;Offset was in opcode.
1336 ((>= bytedecomp-op byte-constant) 1326 ((>= bytedecomp-op byte-constant)
1337 (prog1 (- bytedecomp-op byte-constant) ;offset in opcode 1327 (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
1338 (setq bytedecomp-op byte-constant))) 1328 (setq bytedecomp-op byte-constant)))
1339 ((and (>= bytedecomp-op byte-constant2) 1329 ((or (and (>= bytedecomp-op byte-constant2)
1340 (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) 1330 (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
1331 (= bytedecomp-op byte-stack-set2))
1341 ;; Offset in next 2 bytes. 1332 ;; Offset in next 2 bytes.
1342 (setq bytedecomp-ptr (1+ bytedecomp-ptr)) 1333 (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1343 (+ (aref bytedecomp-bytes bytedecomp-ptr) 1334 (+ (aref bytes bytedecomp-ptr)
1344 (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) 1335 (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1345 (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) 1336 (lsh (aref bytes bytedecomp-ptr) 8))))
1346 ((and (>= bytedecomp-op byte-listN) 1337 ((and (>= bytedecomp-op byte-listN)
1347 (<= bytedecomp-op byte-insertN)) 1338 (<= bytedecomp-op byte-discardN))
1348 (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte 1339 (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
1349 (aref bytedecomp-bytes bytedecomp-ptr)))) 1340 (aref bytes bytedecomp-ptr))))
1350 1341
1342(defvar byte-compile-tag-number)
1351 1343
1352;; This de-compiler is used for inline expansion of compiled functions, 1344;; This de-compiler is used for inline expansion of compiled functions,
1353;; and by the disassembler. 1345;; and by the disassembler.
@@ -1369,27 +1361,26 @@
1369;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. 1361;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
1370;; In that case, we put a pc value into the list 1362;; In that case, we put a pc value into the list
1371;; before each insn (or its label). 1363;; before each insn (or its label).
1372(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec 1364(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
1373 &optional make-spliceable) 1365 (let ((length (length bytes))
1374 (let ((length (length bytedecomp-bytes)) 1366 (bytedecomp-ptr 0) optr tags bytedecomp-op offset
1375 (bytedecomp-ptr 0) optr tags bytedecomp-op offset
1376 lap tmp 1367 lap tmp
1377 endtag) 1368 endtag)
1378 (while (not (= bytedecomp-ptr length)) 1369 (while (not (= bytedecomp-ptr length))
1379 (or make-spliceable 1370 (or make-spliceable
1380 (setq lap (cons bytedecomp-ptr lap))) 1371 (push bytedecomp-ptr lap))
1381 (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) 1372 (setq bytedecomp-op (aref bytes bytedecomp-ptr)
1382 optr bytedecomp-ptr 1373 optr bytedecomp-ptr
1383 offset (disassemble-offset)) ; this does dynamic-scope magic 1374 ;; This uses dynamic-scope magic.
1375 offset (disassemble-offset bytes))
1384 (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) 1376 (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
1385 (cond ((memq bytedecomp-op byte-goto-ops) 1377 (cond ((memq bytedecomp-op byte-goto-ops)
1386 ;; it's a pc 1378 ;; It's a pc.
1387 (setq offset 1379 (setq offset
1388 (cdr (or (assq offset tags) 1380 (cdr (or (assq offset tags)
1389 (car (setq tags 1381 (let ((new (cons offset (byte-compile-make-tag))))
1390 (cons (cons offset 1382 (push new tags)
1391 (byte-compile-make-tag)) 1383 new)))))
1392 tags)))))))
1393 ((cond ((eq bytedecomp-op 'byte-constant2) 1384 ((cond ((eq bytedecomp-op 'byte-constant2)
1394 (setq bytedecomp-op 'byte-constant) t) 1385 (setq bytedecomp-op 'byte-constant) t)
1395 ((memq bytedecomp-op byte-constref-ops))) 1386 ((memq bytedecomp-op byte-constref-ops)))
@@ -1399,36 +1390,36 @@
1399 offset (if (eq bytedecomp-op 'byte-constant) 1390 offset (if (eq bytedecomp-op 'byte-constant)
1400 (byte-compile-get-constant tmp) 1391 (byte-compile-get-constant tmp)
1401 (or (assq tmp byte-compile-variables) 1392 (or (assq tmp byte-compile-variables)
1402 (car (setq byte-compile-variables 1393 (let ((new (list tmp)))
1403 (cons (list tmp) 1394 (push new byte-compile-variables)
1404 byte-compile-variables))))))) 1395 new)))))
1405 ((and make-spliceable 1396 ((eq bytedecomp-op 'byte-stack-set2)
1406 (eq bytedecomp-op 'byte-return)) 1397 (setq bytedecomp-op 'byte-stack-set))
1407 (if (= bytedecomp-ptr (1- length)) 1398 ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
1408 (setq bytedecomp-op nil) 1399 ;; The top bit of the operand for byte-discardN is a flag,
1409 (setq offset (or endtag (setq endtag (byte-compile-make-tag))) 1400 ;; saying whether the top-of-stack is preserved. In
1410 bytedecomp-op 'byte-goto)))) 1401 ;; lapcode, we represent this by using a different opcode
1402 ;; (with the flag removed from the operand).
1403 (setq bytedecomp-op 'byte-discardN-preserve-tos)
1404 (setq offset (- offset #x80))))
1411 ;; lap = ( [ (pc . (op . arg)) ]* ) 1405 ;; lap = ( [ (pc . (op . arg)) ]* )
1412 (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) 1406 (push (cons optr (cons bytedecomp-op (or offset 0)))
1413 lap)) 1407 lap)
1414 (setq bytedecomp-ptr (1+ bytedecomp-ptr))) 1408 (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
1415 ;; take off the dummy nil op that we replaced a trailing "return" with.
1416 (let ((rest lap)) 1409 (let ((rest lap))
1417 (while rest 1410 (while rest
1418 (cond ((numberp (car rest))) 1411 (cond ((numberp (car rest)))
1419 ((setq tmp (assq (car (car rest)) tags)) 1412 ((setq tmp (assq (car (car rest)) tags))
1420 ;; this addr is jumped to 1413 ;; This addr is jumped to.
1421 (setcdr rest (cons (cons nil (cdr tmp)) 1414 (setcdr rest (cons (cons nil (cdr tmp))
1422 (cdr rest))) 1415 (cdr rest)))
1423 (setq tags (delq tmp tags)) 1416 (setq tags (delq tmp tags))
1424 (setq rest (cdr rest)))) 1417 (setq rest (cdr rest))))
1425 (setq rest (cdr rest)))) 1418 (setq rest (cdr rest))))
1426 (if tags (error "optimizer error: missed tags %s" tags)) 1419 (if tags (error "optimizer error: missed tags %s" tags))
1427 (if (null (car (cdr (car lap))))
1428 (setq lap (cdr lap)))
1429 (if endtag 1420 (if endtag
1430 (setq lap (cons (cons nil endtag) lap))) 1421 (setq lap (cons (cons nil endtag) lap)))
1431 ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) 1422 ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
1432 (mapcar (function (lambda (elt) 1423 (mapcar (function (lambda (elt)
1433 (if (numberp elt) 1424 (if (numberp elt)
1434 elt 1425 elt
@@ -1463,7 +1454,7 @@
1463 byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max 1454 byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
1464 byte-point-min byte-following-char byte-preceding-char 1455 byte-point-min byte-following-char byte-preceding-char
1465 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp 1456 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
1466 byte-current-buffer byte-interactive-p)) 1457 byte-current-buffer byte-stack-ref))
1467 1458
1468(defconst byte-compile-side-effect-free-ops 1459(defconst byte-compile-side-effect-free-ops
1469 (nconc 1460 (nconc
@@ -1505,7 +1496,7 @@
1505;; The variable `byte-boolean-vars' is now primitive and updated 1496;; The variable `byte-boolean-vars' is now primitive and updated
1506;; automatically by DEFVAR_BOOL. 1497;; automatically by DEFVAR_BOOL.
1507 1498
1508(defun byte-optimize-lapcode (lap &optional for-effect) 1499(defun byte-optimize-lapcode (lap &optional _for-effect)
1509 "Simple peephole optimizer. LAP is both modified and returned. 1500 "Simple peephole optimizer. LAP is both modified and returned.
1510If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." 1501If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1511 (let (lap0 1502 (let (lap0
@@ -1580,9 +1571,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1580 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup 1571 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1581 ;; The latter two can enable other optimizations. 1572 ;; The latter two can enable other optimizations.
1582 ;; 1573 ;;
1574 ;; For lexical variables, we could do the same
1575 ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1576 ;; but this is a very minor gain, since dup is stack-ref-0,
1577 ;; i.e. it's only better if X>5, and even then it comes
1578 ;; at the cost cost of an extra stack slot. Let's not bother.
1583 ((and (eq 'byte-varref (car lap2)) 1579 ((and (eq 'byte-varref (car lap2))
1584 (eq (cdr lap1) (cdr lap2)) 1580 (eq (cdr lap1) (cdr lap2))
1585 (memq (car lap1) '(byte-varset byte-varbind))) 1581 (memq (car lap1) '(byte-varset byte-varbind)))
1586 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) 1582 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1587 (not (eq (car lap0) 'byte-constant))) 1583 (not (eq (car lap0) 'byte-constant)))
1588 nil 1584 nil
@@ -1611,14 +1607,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1611 ;; 1607 ;;
1612 ;; dup varset-X discard --> varset-X 1608 ;; dup varset-X discard --> varset-X
1613 ;; dup varbind-X discard --> varbind-X 1609 ;; dup varbind-X discard --> varbind-X
1610 ;; dup stack-set-X discard --> stack-set-X-1
1614 ;; (the varbind variant can emerge from other optimizations) 1611 ;; (the varbind variant can emerge from other optimizations)
1615 ;; 1612 ;;
1616 ((and (eq 'byte-dup (car lap0)) 1613 ((and (eq 'byte-dup (car lap0))
1617 (eq 'byte-discard (car lap2)) 1614 (eq 'byte-discard (car lap2))
1618 (memq (car lap1) '(byte-varset byte-varbind))) 1615 (memq (car lap1) '(byte-varset byte-varbind
1616 byte-stack-set)))
1619 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) 1617 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1620 (setq keep-going t 1618 (setq keep-going t
1621 rest (cdr rest)) 1619 rest (cdr rest))
1620 (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
1622 (setq lap (delq lap0 (delq lap2 lap)))) 1621 (setq lap (delq lap0 (delq lap2 lap))))
1623 ;; 1622 ;;
1624 ;; not goto-X-if-nil --> goto-X-if-non-nil 1623 ;; not goto-X-if-nil --> goto-X-if-non-nil
@@ -1627,8 +1626,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1627 ;; it is wrong to do the same thing for the -else-pop variants. 1626 ;; it is wrong to do the same thing for the -else-pop variants.
1628 ;; 1627 ;;
1629 ((and (eq 'byte-not (car lap0)) 1628 ((and (eq 'byte-not (car lap0))
1630 (or (eq 'byte-goto-if-nil (car lap1)) 1629 (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1631 (eq 'byte-goto-if-not-nil (car lap1))))
1632 (byte-compile-log-lap " not %s\t-->\t%s" 1630 (byte-compile-log-lap " not %s\t-->\t%s"
1633 lap1 1631 lap1
1634 (cons 1632 (cons
@@ -1647,8 +1645,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1647 ;; 1645 ;;
1648 ;; it is wrong to do the same thing for the -else-pop variants. 1646 ;; it is wrong to do the same thing for the -else-pop variants.
1649 ;; 1647 ;;
1650 ((and (or (eq 'byte-goto-if-nil (car lap0)) 1648 ((and (memq (car lap0)
1651 (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX 1649 '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1652 (eq 'byte-goto (car lap1)) ; gotoY 1650 (eq 'byte-goto (car lap1)) ; gotoY
1653 (eq (cdr lap0) lap2)) ; TAG X 1651 (eq (cdr lap0) lap2)) ; TAG X
1654 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) 1652 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
@@ -1663,40 +1661,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1663 ;; const goto-if-* --> whatever 1661 ;; const goto-if-* --> whatever
1664 ;; 1662 ;;
1665 ((and (eq 'byte-constant (car lap0)) 1663 ((and (eq 'byte-constant (car lap0))
1666 (memq (car lap1) byte-conditional-ops)) 1664 (memq (car lap1) byte-conditional-ops)
1667 (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) 1665 ;; If the `byte-constant's cdr is not a cons cell, it has
1668 (eq (car lap1) 'byte-goto-if-nil-else-pop)) 1666 ;; to be an index into the constant pool); even though
1669 (car (cdr lap0)) 1667 ;; it'll be a constant, that constant is not known yet
1670 (not (car (cdr lap0)))) 1668 ;; (it's typically a free variable of a closure, so will
1669 ;; only be known when the closure will be built at
1670 ;; run-time).
1671 (consp (cdr lap0)))
1672 (cond ((if (memq (car lap1) '(byte-goto-if-nil
1673 byte-goto-if-nil-else-pop))
1674 (car (cdr lap0))
1675 (not (car (cdr lap0))))
1671 (byte-compile-log-lap " %s %s\t-->\t<deleted>" 1676 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1672 lap0 lap1) 1677 lap0 lap1)
1673 (setq rest (cdr rest) 1678 (setq rest (cdr rest)
1674 lap (delq lap0 (delq lap1 lap)))) 1679 lap (delq lap0 (delq lap1 lap))))
1675 (t 1680 (t
1676 (if (memq (car lap1) byte-goto-always-pop-ops) 1681 (byte-compile-log-lap " %s %s\t-->\t%s"
1677 (progn 1682 lap0 lap1
1678 (byte-compile-log-lap " %s %s\t-->\t%s" 1683 (cons 'byte-goto (cdr lap1)))
1679 lap0 lap1 (cons 'byte-goto (cdr lap1))) 1684 (when (memq (car lap1) byte-goto-always-pop-ops)
1680 (setq lap (delq lap0 lap))) 1685 (setq lap (delq lap0 lap)))
1681 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
1682 (cons 'byte-goto (cdr lap1))))
1683 (setcar lap1 'byte-goto))) 1686 (setcar lap1 'byte-goto)))
1684 (setq keep-going t)) 1687 (setq keep-going t))
1685 ;; 1688 ;;
1686 ;; varref-X varref-X --> varref-X dup 1689 ;; varref-X varref-X --> varref-X dup
1687 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup 1690 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1691 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1688 ;; We don't optimize the const-X variations on this here, 1692 ;; We don't optimize the const-X variations on this here,
1689 ;; because that would inhibit some goto optimizations; we 1693 ;; because that would inhibit some goto optimizations; we
1690 ;; optimize the const-X case after all other optimizations. 1694 ;; optimize the const-X case after all other optimizations.
1691 ;; 1695 ;;
1692 ((and (eq 'byte-varref (car lap0)) 1696 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1693 (progn 1697 (progn
1694 (setq tmp (cdr rest)) 1698 (setq tmp (cdr rest))
1699 (setq tmp2 0)
1695 (while (eq (car (car tmp)) 'byte-dup) 1700 (while (eq (car (car tmp)) 'byte-dup)
1696 (setq tmp (cdr tmp))) 1701 (setq tmp2 (1+ tmp2))
1702 (setq tmp (cdr tmp)))
1697 t) 1703 t)
1698 (eq (cdr lap0) (cdr (car tmp))) 1704 (eq (if (eq 'byte-stack-ref (car lap0))
1699 (eq 'byte-varref (car (car tmp)))) 1705 (+ tmp2 1 (cdr lap0))
1706 (cdr lap0))
1707 (cdr (car tmp)))
1708 (eq (car lap0) (car (car tmp))))
1700 (if (memq byte-optimize-log '(t byte)) 1709 (if (memq byte-optimize-log '(t byte))
1701 (let ((str "")) 1710 (let ((str ""))
1702 (setq tmp2 (cdr rest)) 1711 (setq tmp2 (cdr rest))
@@ -1856,18 +1865,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1856 (cons 'byte-discard byte-conditional-ops))) 1865 (cons 'byte-discard byte-conditional-ops)))
1857 (not (eq lap1 (car tmp)))) 1866 (not (eq lap1 (car tmp))))
1858 (setq tmp2 (car tmp)) 1867 (setq tmp2 (car tmp))
1859 (cond ((memq (car tmp2) 1868 (cond ((when (consp (cdr lap0))
1860 (if (null (car (cdr lap0))) 1869 (memq (car tmp2)
1861 '(byte-goto-if-nil byte-goto-if-nil-else-pop) 1870 (if (null (car (cdr lap0)))
1862 '(byte-goto-if-not-nil 1871 '(byte-goto-if-nil byte-goto-if-nil-else-pop)
1863 byte-goto-if-not-nil-else-pop))) 1872 '(byte-goto-if-not-nil
1873 byte-goto-if-not-nil-else-pop))))
1864 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" 1874 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
1865 lap0 tmp2 lap0 tmp2) 1875 lap0 tmp2 lap0 tmp2)
1866 (setcar lap1 (car tmp2)) 1876 (setcar lap1 (car tmp2))
1867 (setcdr lap1 (cdr tmp2)) 1877 (setcdr lap1 (cdr tmp2))
1868 ;; Let next step fix the (const,goto-if*) sequence. 1878 ;; Let next step fix the (const,goto-if*) sequence.
1869 (setq rest (cons nil rest))) 1879 (setq rest (cons nil rest))
1870 (t 1880 (setq keep-going t))
1881 ((or (consp (cdr lap0))
1882 (eq (car tmp2) 'byte-discard))
1871 ;; Jump one step further 1883 ;; Jump one step further
1872 (byte-compile-log-lap 1884 (byte-compile-log-lap
1873 " %s goto [%s]\t-->\t<deleted> goto <skip>" 1885 " %s goto [%s]\t-->\t<deleted> goto <skip>"
@@ -1876,13 +1888,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1876 (setcdr tmp (cons (byte-compile-make-tag) 1888 (setcdr tmp (cons (byte-compile-make-tag)
1877 (cdr tmp)))) 1889 (cdr tmp))))
1878 (setcdr lap1 (car (cdr tmp))) 1890 (setcdr lap1 (car (cdr tmp)))
1879 (setq lap (delq lap0 lap)))) 1891 (setq lap (delq lap0 lap))
1880 (setq keep-going t)) 1892 (setq keep-going t))))
1881 ;; 1893 ;;
1882 ;; X: varref-Y ... varset-Y goto-X --> 1894 ;; X: varref-Y ... varset-Y goto-X -->
1883 ;; X: varref-Y Z: ... dup varset-Y goto-Z 1895 ;; X: varref-Y Z: ... dup varset-Y goto-Z
1884 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) 1896 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1885 ;; (This is so usual for while loops that it is worth handling). 1897 ;; (This is so usual for while loops that it is worth handling).
1898 ;;
1899 ;; Here again, we could do it for stack-ref/stack-set, but
1900 ;; that's replacing a stack-ref-Y with a stack-ref-0, which
1901 ;; is a very minor improvement (if any), at the cost of
1902 ;; more stack use and more byte-code. Let's not do it.
1886 ;; 1903 ;;
1887 ((and (eq (car lap1) 'byte-varset) 1904 ((and (eq (car lap1) 'byte-varset)
1888 (eq (car lap2) 'byte-goto) 1905 (eq (car lap2) 'byte-goto)
@@ -1955,16 +1972,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1955 ;; Rebuild byte-compile-constants / byte-compile-variables. 1972 ;; Rebuild byte-compile-constants / byte-compile-variables.
1956 ;; Simple optimizations that would inhibit other optimizations if they 1973 ;; Simple optimizations that would inhibit other optimizations if they
1957 ;; were done in the optimizing loop, and optimizations which there is no 1974 ;; were done in the optimizing loop, and optimizations which there is no
1958 ;; need to do more than once. 1975 ;; need to do more than once.
1959 (setq byte-compile-constants nil 1976 (setq byte-compile-constants nil
1960 byte-compile-variables nil) 1977 byte-compile-variables nil)
1961 (setq rest lap) 1978 (setq rest lap)
1979 (byte-compile-log-lap " ---- final pass")
1962 (while rest 1980 (while rest
1963 (setq lap0 (car rest) 1981 (setq lap0 (car rest)
1964 lap1 (nth 1 rest)) 1982 lap1 (nth 1 rest))
1965 (if (memq (car lap0) byte-constref-ops) 1983 (if (memq (car lap0) byte-constref-ops)
1966 (if (or (eq (car lap0) 'byte-constant) 1984 (if (memq (car lap0) '(byte-constant byte-constant2))
1967 (eq (car lap0) 'byte-constant2))
1968 (unless (memq (cdr lap0) byte-compile-constants) 1985 (unless (memq (cdr lap0) byte-compile-constants)
1969 (setq byte-compile-constants (cons (cdr lap0) 1986 (setq byte-compile-constants (cons (cdr lap0)
1970 byte-compile-constants))) 1987 byte-compile-constants)))
@@ -2008,10 +2025,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
2008 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 2025 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
2009 (cons 'byte-unbind 2026 (cons 'byte-unbind
2010 (+ (cdr lap0) (cdr lap1)))) 2027 (+ (cdr lap0) (cdr lap1))))
2011 (setq keep-going t)
2012 (setq lap (delq lap0 lap)) 2028 (setq lap (delq lap0 lap))
2013 (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) 2029 (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
2014 ) 2030
2031 ;;
2032 ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
2033 ;; stack-set-M [discard/discardN ...] --> discardN
2034 ;;
2035 ((and (eq (car lap0) 'byte-stack-set)
2036 (memq (car lap1) '(byte-discard byte-discardN))
2037 (progn
2038 ;; See if enough discard operations follow to expose or
2039 ;; destroy the value stored by the stack-set.
2040 (setq tmp (cdr rest))
2041 (setq tmp2 (1- (cdr lap0)))
2042 (setq tmp3 0)
2043 (while (memq (car (car tmp)) '(byte-discard byte-discardN))
2044 (setq tmp3
2045 (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
2046 1
2047 (cdr (car tmp)))))
2048 (setq tmp (cdr tmp)))
2049 (>= tmp3 tmp2)))
2050 ;; Do the optimization.
2051 (setq lap (delq lap0 lap))
2052 (setcar lap1
2053 (if (= tmp2 tmp3)
2054 ;; The value stored is the new TOS, so pop one more
2055 ;; value (to get rid of the old value) using the
2056 ;; TOS-preserving discard operator.
2057 'byte-discardN-preserve-tos
2058 ;; Otherwise, the value stored is lost, so just use a
2059 ;; normal discard.
2060 'byte-discardN))
2061 (setcdr lap1 (1+ tmp3))
2062 (setcdr (cdr rest) tmp)
2063 (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
2064 lap0 lap1))
2065
2066 ;;
2067 ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
2068 ;; discardN-(X+Y)
2069 ;;
2070 ((and (memq (car lap0)
2071 '(byte-discard byte-discardN
2072 byte-discardN-preserve-tos))
2073 (memq (car lap1) '(byte-discard byte-discardN)))
2074 (setq lap (delq lap0 lap))
2075 (byte-compile-log-lap
2076 " %s %s\t-->\t(discardN %s)"
2077 lap0 lap1
2078 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2079 (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2080 (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2081 (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2082 (setcar lap1 'byte-discardN))
2083
2084 ;;
2085 ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
2086 ;; discardN-preserve-tos-(X+Y)
2087 ;;
2088 ((and (eq (car lap0) 'byte-discardN-preserve-tos)
2089 (eq (car lap1) 'byte-discardN-preserve-tos))
2090 (setq lap (delq lap0 lap))
2091 (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
2092 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
2093
2094 ;;
2095 ;; discardN-preserve-tos return --> return
2096 ;; dup return --> return
2097 ;; stack-set-N return --> return ; where N is TOS-1
2098 ;;
2099 ((and (eq (car lap1) 'byte-return)
2100 (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
2101 (and (eq (car lap0) 'byte-stack-set)
2102 (= (cdr lap0) 1))))
2103 ;; The byte-code interpreter will pop the stack for us, so
2104 ;; we can just leave stuff on it.
2105 (setq lap (delq lap0 lap))
2106 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
2107 )
2015 (setq rest (cdr rest))) 2108 (setq rest (cdr rest)))
2016 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) 2109 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
2017 lap) 2110 lap)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 524f4f1b465..3fb3d841ed1 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message
123If provided, WHEN should be a string indicating when the function 123If provided, WHEN should be a string indicating when the function
124was first made obsolete, for example a date or a release number." 124was first made obsolete, for example a date or a release number."
125 (interactive "aMake function obsolete: \nxObsoletion replacement: ") 125 (interactive "aMake function obsolete: \nxObsoletion replacement: ")
126 (let ((handler (get obsolete-name 'byte-compile))) 126 (put obsolete-name 'byte-obsolete-info
127 (if (eq 'byte-compile-obsolete handler) 127 ;; The second entry used to hold the `byte-compile' handler, but
128 (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info))) 128 ;; is not used any more nowadays.
129 (put obsolete-name 'byte-compile 'byte-compile-obsolete)) 129 (list (purecopy current-name) nil (purecopy when)))
130 (put obsolete-name 'byte-obsolete-info
131 (list (purecopy current-name) handler (purecopy when))))
132 obsolete-name) 130 obsolete-name)
133(set-advertised-calling-convention 131(set-advertised-calling-convention
134 ;; New code should always provide the `when' argument. 132 ;; New code should always provide the `when' argument.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 5c845e59c85..7c358a3830e 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1,4 +1,4 @@
1;;; bytecomp.el --- compilation of Lisp code into byte code 1;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011 3;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2011
4;; Free Software Foundation, Inc. 4;; Free Software Foundation, Inc.
@@ -118,12 +118,16 @@
118;; Some versions of `file' can be customized to recognize that. 118;; Some versions of `file' can be customized to recognize that.
119 119
120(require 'backquote) 120(require 'backquote)
121(require 'macroexp)
122(require 'cconv)
121(eval-when-compile (require 'cl)) 123(eval-when-compile (require 'cl))
122 124
123(or (fboundp 'defsubst) 125(or (fboundp 'defsubst)
124 ;; This really ought to be loaded already! 126 ;; This really ought to be loaded already!
125 (load "byte-run")) 127 (load "byte-run"))
126 128
129;; The feature of compiling in a specific target Emacs version
130;; has been turned off because compile time options are a bad idea.
127(defgroup bytecomp nil 131(defgroup bytecomp nil
128 "Emacs Lisp byte-compiler." 132 "Emacs Lisp byte-compiler."
129 :group 'lisp) 133 :group 'lisp)
@@ -402,7 +406,7 @@ specify different fields to sort on."
402(defvar byte-compile-variables nil 406(defvar byte-compile-variables nil
403 "List of all variables encountered during compilation of this form.") 407 "List of all variables encountered during compilation of this form.")
404(defvar byte-compile-bound-variables nil 408(defvar byte-compile-bound-variables nil
405 "List of variables bound in the context of the current form. 409 "List of dynamic variables bound in the context of the current form.
406This list lives partly on the stack.") 410This list lives partly on the stack.")
407(defvar byte-compile-const-variables nil 411(defvar byte-compile-const-variables nil
408 "List of variables declared as constants during compilation of this file.") 412 "List of variables declared as constants during compilation of this file.")
@@ -415,10 +419,13 @@ This list lives partly on the stack.")
415 '( 419 '(
416;; (byte-compiler-options . (lambda (&rest forms) 420;; (byte-compiler-options . (lambda (&rest forms)
417;; (apply 'byte-compiler-options-handler forms))) 421;; (apply 'byte-compiler-options-handler forms)))
422 (declare-function . byte-compile-macroexpand-declare-function)
418 (eval-when-compile . (lambda (&rest body) 423 (eval-when-compile . (lambda (&rest body)
419 (list 'quote 424 (list
420 (byte-compile-eval (byte-compile-top-level 425 'quote
421 (cons 'progn body)))))) 426 (byte-compile-eval
427 (byte-compile-top-level
428 (byte-compile-preprocess (cons 'progn body)))))))
422 (eval-and-compile . (lambda (&rest body) 429 (eval-and-compile . (lambda (&rest body)
423 (byte-compile-eval-before-compile (cons 'progn body)) 430 (byte-compile-eval-before-compile (cons 'progn body))
424 (cons 'progn body)))) 431 (cons 'progn body))))
@@ -451,6 +458,10 @@ defined with incorrect args.")
451Used for warnings about calling a function that is defined during compilation 458Used for warnings about calling a function that is defined during compilation
452but won't necessarily be defined when the compiled file is loaded.") 459but won't necessarily be defined when the compiled file is loaded.")
453 460
461;; Variables for lexical binding
462(defvar byte-compile--lexical-environment nil
463 "The current lexical environment.")
464
454(defvar byte-compile-tag-number 0) 465(defvar byte-compile-tag-number 0)
455(defvar byte-compile-output nil 466(defvar byte-compile-output nil
456 "Alist describing contents to put in byte code string. 467 "Alist describing contents to put in byte code string.
@@ -496,11 +507,10 @@ Each element is (INDEX . VALUE)")
496 (put 'byte-stack+-info 'tmp-compile-time-value nil))) 507 (put 'byte-stack+-info 'tmp-compile-time-value nil)))
497 508
498 509
499;; unused: 0-7
500
501;; These opcodes are special in that they pack their argument into the 510;; These opcodes are special in that they pack their argument into the
502;; opcode word. 511;; opcode word.
503;; 512;;
513(byte-defop 0 1 byte-stack-ref "for stack reference")
504(byte-defop 8 1 byte-varref "for variable reference") 514(byte-defop 8 1 byte-varref "for variable reference")
505(byte-defop 16 -1 byte-varset "for setting a variable") 515(byte-defop 16 -1 byte-varset "for setting a variable")
506(byte-defop 24 -1 byte-varbind "for binding a variable") 516(byte-defop 24 -1 byte-varbind "for binding a variable")
@@ -570,7 +580,7 @@ Each element is (INDEX . VALUE)")
570(byte-defop 114 0 byte-save-current-buffer 580(byte-defop 114 0 byte-save-current-buffer
571 "To make a binding to record the current buffer") 581 "To make a binding to record the current buffer")
572(byte-defop 115 0 byte-set-mark-OBSOLETE) 582(byte-defop 115 0 byte-set-mark-OBSOLETE)
573(byte-defop 116 1 byte-interactive-p) 583;; (byte-defop 116 1 byte-interactive-p) ;Let's not use it any more.
574 584
575;; These ops are new to v19 585;; These ops are new to v19
576(byte-defop 117 0 byte-forward-char) 586(byte-defop 117 0 byte-forward-char)
@@ -606,8 +616,8 @@ otherwise pop it")
606 616
607(byte-defop 138 0 byte-save-excursion 617(byte-defop 138 0 byte-save-excursion
608 "to make a binding to record the buffer, point and mark") 618 "to make a binding to record the buffer, point and mark")
609(byte-defop 139 0 byte-save-window-excursion 619;; (byte-defop 139 0 byte-save-window-excursion ; Obsolete: It's a macro now.
610 "to make a binding to record entire window configuration") 620;; "to make a binding to record entire window configuration")
611(byte-defop 140 0 byte-save-restriction 621(byte-defop 140 0 byte-save-restriction
612 "to make a binding to record the current buffer clipping restrictions") 622 "to make a binding to record the current buffer clipping restrictions")
613(byte-defop 141 -1 byte-catch 623(byte-defop 141 -1 byte-catch
@@ -619,17 +629,9 @@ otherwise pop it")
619;; an expression for the body, and a list of clauses. 629;; an expression for the body, and a list of clauses.
620(byte-defop 143 -2 byte-condition-case) 630(byte-defop 143 -2 byte-condition-case)
621 631
622;; For entry to with-output-to-temp-buffer. 632;; Obsolete: `with-output-to-temp-buffer' is a macro now.
623;; Takes, on stack, the buffer name. 633;; (byte-defop 144 0 byte-temp-output-buffer-setup)
624;; Binds standard-output and does some other things. 634;; (byte-defop 145 -1 byte-temp-output-buffer-show)
625;; Returns with temp buffer on the stack in place of buffer name.
626(byte-defop 144 0 byte-temp-output-buffer-setup)
627
628;; For exit from with-output-to-temp-buffer.
629;; Expects the temp buffer on the stack underneath value to return.
630;; Pops them both, then pushes the value back on.
631;; Unbinds standard-output and makes the temp buffer visible.
632(byte-defop 145 -1 byte-temp-output-buffer-show)
633 635
634;; these ops are new to v19 636;; these ops are new to v19
635 637
@@ -666,7 +668,21 @@ otherwise pop it")
666(byte-defop 176 nil byte-concatN) 668(byte-defop 176 nil byte-concatN)
667(byte-defop 177 nil byte-insertN) 669(byte-defop 177 nil byte-insertN)
668 670
669;; unused: 178-191 671(byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte.
672(byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes.
673
674;; If (following one byte & 0x80) == 0
675;; discard (following one byte & 0x7F) stack entries
676;; else
677;; discard (following one byte & 0x7F) stack entries _underneath_ TOS
678;; (that is, if the operand = 0x83, ... X Y Z T => ... T)
679(byte-defop 182 nil byte-discardN)
680;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into
681;; `byte-discardN' with the high bit in the operand set (by
682;; `byte-compile-lapcode').
683(defconst byte-discardN-preserve-tos byte-discardN)
684
685;; unused: 182-191
670 686
671(byte-defop 192 1 byte-constant "for reference to a constant") 687(byte-defop 192 1 byte-constant "for reference to a constant")
672;; codes 193-255 are consumed by byte-constant. 688;; codes 193-255 are consumed by byte-constant.
@@ -713,71 +729,114 @@ otherwise pop it")
713;; front of the constants-vector than the constant-referencing instructions. 729;; front of the constants-vector than the constant-referencing instructions.
714;; Also, this lets us notice references to free variables. 730;; Also, this lets us notice references to free variables.
715 731
732(defmacro byte-compile-push-bytecodes (&rest args)
733 "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
734ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
735BYTES and PC are updated after evaluating all the arguments."
736 (let ((byte-exprs (butlast args 2))
737 (bytes-var (car (last args 2)))
738 (pc-var (car (last args))))
739 `(setq ,bytes-var ,(if (null (cdr byte-exprs))
740 `(progn (assert (<= 0 ,(car byte-exprs)))
741 (cons ,@byte-exprs ,bytes-var))
742 `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
743 ,pc-var (+ ,(length byte-exprs) ,pc-var))))
744
745(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
746 "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
747CONST2 may be evaulated multiple times."
748 `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
749 ,bytes ,pc))
750
716(defun byte-compile-lapcode (lap) 751(defun byte-compile-lapcode (lap)
717 "Turns lapcode into bytecode. The lapcode is destroyed." 752 "Turns lapcode into bytecode. The lapcode is destroyed."
718 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. 753 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
719 (let ((pc 0) ; Program counter 754 (let ((pc 0) ; Program counter
720 op off ; Operation & offset 755 op off ; Operation & offset
756 opcode ; numeric value of OP
721 (bytes '()) ; Put the output bytes here 757 (bytes '()) ; Put the output bytes here
722 (patchlist nil)) ; List of tags and goto's to patch 758 (patchlist nil)) ; List of gotos to patch
723 (while lap 759 (dolist (lap-entry lap)
724 (setq op (car (car lap)) 760 (setq op (car lap-entry)
725 off (cdr (car lap))) 761 off (cdr lap-entry))
726 (cond ((not (symbolp op)) 762 (cond
727 (error "Non-symbolic opcode `%s'" op)) 763 ((not (symbolp op))
728 ((eq op 'TAG) 764 (error "Non-symbolic opcode `%s'" op))
729 (setcar off pc) 765 ((eq op 'TAG)
730 (setq patchlist (cons off patchlist))) 766 (setcar off pc))
731 ((memq op byte-goto-ops) 767 (t
732 (setq pc (+ pc 3)) 768 (setq opcode
733 (setq bytes (cons (cons pc (cdr off)) 769 (if (eq op 'byte-discardN-preserve-tos)
734 (cons nil 770 ;; byte-discardN-preserve-tos is a pseudo op, which
735 (cons (symbol-value op) bytes)))) 771 ;; is actually the same as byte-discardN
736 (setq patchlist (cons bytes patchlist))) 772 ;; with a modified argument.
737 (t 773 byte-discardN
738 (setq bytes 774 (symbol-value op)))
739 (cond ((cond ((consp off) 775 (cond ((memq op byte-goto-ops)
740 ;; Variable or constant reference 776 ;; goto
741 (setq off (cdr off)) 777 (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
742 (eq op 'byte-constant))) 778 (push bytes patchlist))
743 (cond ((< off byte-constant-limit) 779 ((or (and (consp off)
744 (setq pc (1+ pc)) 780 ;; Variable or constant reference
745 (cons (+ byte-constant off) bytes)) 781 (progn
746 (t 782 (setq off (cdr off))
747 (setq pc (+ 3 pc)) 783 (eq op 'byte-constant)))
748 (cons (lsh off -8) 784 (and (eq op 'byte-constant)
749 (cons (logand off 255) 785 (integerp off)))
750 (cons byte-constant2 bytes)))))) 786 ;; constant ref
751 ((<= byte-listN (symbol-value op)) 787 (if (< off byte-constant-limit)
752 (setq pc (+ 2 pc)) 788 (byte-compile-push-bytecodes (+ byte-constant off)
753 (cons off (cons (symbol-value op) bytes))) 789 bytes pc)
754 ((< off 6) 790 (byte-compile-push-bytecode-const2 byte-constant2 off
755 (setq pc (1+ pc)) 791 bytes pc)))
756 (cons (+ (symbol-value op) off) bytes)) 792 ((and (= opcode byte-stack-set)
757 ((< off 256) 793 (> off 255))
758 (setq pc (+ 2 pc)) 794 ;; Use the two-byte version of byte-stack-set if the
759 (cons off (cons (+ (symbol-value op) 6) bytes))) 795 ;; offset is too large for the normal version.
760 (t 796 (byte-compile-push-bytecode-const2 byte-stack-set2 off
761 (setq pc (+ 3 pc)) 797 bytes pc))
762 (cons (lsh off -8) 798 ((and (>= opcode byte-listN)
763 (cons (logand off 255) 799 (< opcode byte-discardN))
764 (cons (+ (symbol-value op) 7) 800 ;; These insns all put their operand into one extra byte.
765 bytes)))))))) 801 (byte-compile-push-bytecodes opcode off bytes pc))
766 (setq lap (cdr lap))) 802 ((= opcode byte-discardN)
803 ;; byte-discardN is weird in that it encodes a flag in the
804 ;; top bit of its one-byte argument. If the argument is
805 ;; too large to fit in 7 bits, the opcode can be repeated.
806 (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
807 (while (> off #x7f)
808 (byte-compile-push-bytecodes opcode (logior #x7f flag)
809 bytes pc)
810 (setq off (- off #x7f)))
811 (byte-compile-push-bytecodes opcode (logior off flag)
812 bytes pc)))
813 ((null off)
814 ;; opcode that doesn't use OFF
815 (byte-compile-push-bytecodes opcode bytes pc))
816 ((and (eq opcode byte-stack-ref) (eq off 0))
817 ;; (stack-ref 0) is really just another name for `dup'.
818 (debug) ;FIXME: When would this happen?
819 (byte-compile-push-bytecodes byte-dup bytes pc))
820 ;; The following three cases are for the special
821 ;; insns that encode their operand into 0, 1, or 2
822 ;; extra bytes depending on its magnitude.
823 ((< off 6)
824 (byte-compile-push-bytecodes (+ opcode off) bytes pc))
825 ((< off 256)
826 (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
827 (t
828 (byte-compile-push-bytecode-const2 (+ opcode 7) off
829 bytes pc))))))
767 ;;(if (not (= pc (length bytes))) 830 ;;(if (not (= pc (length bytes)))
768 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) 831 ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
769 ;; Patch PC into jumps 832 ;; Patch tag PCs into absolute jumps.
770 (let (bytes) 833 (dolist (bytes-tail patchlist)
771 (while patchlist 834 (setq pc (caar bytes-tail)) ; Pick PC from goto's tag.
772 (setq bytes (car patchlist)) 835 (setcar (cdr bytes-tail) (logand pc 255))
773 (cond ((atom (car bytes))) ; Tag 836 (setcar bytes-tail (lsh pc -8))
774 (t ; Absolute jump 837 ;; FIXME: Replace this by some workaround.
775 (setq pc (car (cdr (car bytes)))) ; Pick PC from tag 838 (if (> (car bytes) 255) (error "Bytecode overflow")))
776 (setcar (cdr bytes) (logand pc 255)) 839
777 (setcar bytes (lsh pc -8))
778 ;; FIXME: Replace this by some workaround.
779 (if (> (car bytes) 255) (error "Bytecode overflow"))))
780 (setq patchlist (cdr patchlist))))
781 (apply 'unibyte-string (nreverse bytes)))) 840 (apply 'unibyte-string (nreverse bytes))))
782 841
783 842
@@ -793,7 +852,7 @@ otherwise pop it")
793Each function's symbol gets added to `byte-compile-noruntime-functions'." 852Each function's symbol gets added to `byte-compile-noruntime-functions'."
794 (let ((hist-orig load-history) 853 (let ((hist-orig load-history)
795 (hist-nil-orig current-load-list)) 854 (hist-nil-orig current-load-list))
796 (prog1 (eval form) 855 (prog1 (eval form lexical-binding)
797 (when (byte-compile-warning-enabled-p 'noruntime) 856 (when (byte-compile-warning-enabled-p 'noruntime)
798 (let ((hist-new load-history) 857 (let ((hist-new load-history)
799 (hist-nil-new current-load-list)) 858 (hist-nil-new current-load-list))
@@ -845,7 +904,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
845(defun byte-compile-eval-before-compile (form) 904(defun byte-compile-eval-before-compile (form)
846 "Evaluate FORM for `eval-and-compile'." 905 "Evaluate FORM for `eval-and-compile'."
847 (let ((hist-nil-orig current-load-list)) 906 (let ((hist-nil-orig current-load-list))
848 (prog1 (eval form) 907 (prog1 (eval form lexical-binding)
849 ;; (eval-and-compile (require 'cl) turns off warnings for cl functions. 908 ;; (eval-and-compile (require 'cl) turns off warnings for cl functions.
850 ;; FIXME Why does it do that - just as a hack? 909 ;; FIXME Why does it do that - just as a hack?
851 ;; There are other ways to do this nowadays. 910 ;; There are other ways to do this nowadays.
@@ -936,7 +995,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
936 read-symbol-positions-list 995 read-symbol-positions-list
937 (byte-compile-delete-first 996 (byte-compile-delete-first
938 entry read-symbol-positions-list))) 997 entry read-symbol-positions-list)))
939 (or (and allow-previous (not (= last byte-compile-last-position))) 998 (or (and allow-previous
999 (not (= last byte-compile-last-position)))
940 (> last byte-compile-last-position))))))) 1000 (> last byte-compile-last-position)))))))
941 1001
942(defvar byte-compile-last-warned-form nil) 1002(defvar byte-compile-last-warned-form nil)
@@ -948,7 +1008,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
948 (let* ((inhibit-read-only t) 1008 (let* ((inhibit-read-only t)
949 (dir default-directory) 1009 (dir default-directory)
950 (file (cond ((stringp byte-compile-current-file) 1010 (file (cond ((stringp byte-compile-current-file)
951 (format "%s:" (file-relative-name byte-compile-current-file dir))) 1011 (format "%s:" (file-relative-name
1012 byte-compile-current-file dir)))
952 ((bufferp byte-compile-current-file) 1013 ((bufferp byte-compile-current-file)
953 (format "Buffer %s:" 1014 (format "Buffer %s:"
954 (buffer-name byte-compile-current-file))) 1015 (buffer-name byte-compile-current-file)))
@@ -982,7 +1043,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
982;; This no-op function is used as the value of warning-series 1043;; This no-op function is used as the value of warning-series
983;; to tell inner calls to displaying-byte-compile-warnings 1044;; to tell inner calls to displaying-byte-compile-warnings
984;; not to bind warning-series. 1045;; not to bind warning-series.
985(defun byte-compile-warning-series (&rest ignore) 1046(defun byte-compile-warning-series (&rest _ignore)
986 nil) 1047 nil)
987 1048
988;; (compile-mode) will cause this to be loaded. 1049;; (compile-mode) will cause this to be loaded.
@@ -1011,13 +1072,15 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
1011 (insert "\f\nCompiling " 1072 (insert "\f\nCompiling "
1012 (if (stringp byte-compile-current-file) 1073 (if (stringp byte-compile-current-file)
1013 (concat "file " byte-compile-current-file) 1074 (concat "file " byte-compile-current-file)
1014 (concat "buffer " (buffer-name byte-compile-current-file))) 1075 (concat "buffer "
1076 (buffer-name byte-compile-current-file)))
1015 " at " (current-time-string) "\n") 1077 " at " (current-time-string) "\n")
1016 (insert "\f\nCompiling no file at " (current-time-string) "\n")) 1078 (insert "\f\nCompiling no file at " (current-time-string) "\n"))
1017 (when dir 1079 (when dir
1018 (setq default-directory dir) 1080 (setq default-directory dir)
1019 (unless was-same 1081 (unless was-same
1020 (insert (format "Entering directory `%s'\n" default-directory)))) 1082 (insert (format "Entering directory `%s'\n"
1083 default-directory))))
1021 (setq byte-compile-last-logged-file byte-compile-current-file 1084 (setq byte-compile-last-logged-file byte-compile-current-file
1022 byte-compile-last-warned-form nil) 1085 byte-compile-last-warned-form nil)
1023 ;; Do this after setting default-directory. 1086 ;; Do this after setting default-directory.
@@ -1064,13 +1127,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
1064 (byte-compile-log-warning 1127 (byte-compile-log-warning
1065 (error-message-string error-info) 1128 (error-message-string error-info)
1066 nil :error)) 1129 nil :error))
1067
1068;;; Used by make-obsolete.
1069(defun byte-compile-obsolete (form)
1070 (byte-compile-set-symbol-position (car form))
1071 (byte-compile-warn-obsolete (car form))
1072 (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler
1073 'byte-compile-normal-call) form))
1074 1130
1075;;; sanity-checking arglists 1131;;; sanity-checking arglists
1076 1132
@@ -1110,22 +1166,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
1110 (t fn))))))) 1166 (t fn)))))))
1111 1167
1112(defun byte-compile-arglist-signature (arglist) 1168(defun byte-compile-arglist-signature (arglist)
1113 (let ((args 0) 1169 (if (integerp arglist)
1114 opts 1170 ;; New style byte-code arglist.
1115 restp) 1171 (cons (logand arglist 127) ;Mandatory.
1116 (while arglist 1172 (if (zerop (logand arglist 128)) ;No &rest.
1117 (cond ((eq (car arglist) '&optional) 1173 (lsh arglist -8))) ;Nonrest.
1118 (or opts (setq opts 0))) 1174 ;; Old style byte-code, or interpreted function.
1119 ((eq (car arglist) '&rest) 1175 (let ((args 0)
1120 (if (cdr arglist) 1176 opts
1121 (setq restp t 1177 restp)
1122 arglist nil))) 1178 (while arglist
1123 (t 1179 (cond ((eq (car arglist) '&optional)
1124 (if opts 1180 (or opts (setq opts 0)))
1125 (setq opts (1+ opts)) 1181 ((eq (car arglist) '&rest)
1182 (if (cdr arglist)
1183 (setq restp t
1184 arglist nil)))
1185 (t
1186 (if opts
1187 (setq opts (1+ opts))
1126 (setq args (1+ args))))) 1188 (setq args (1+ args)))))
1127 (setq arglist (cdr arglist))) 1189 (setq arglist (cdr arglist)))
1128 (cons args (if restp nil (if opts (+ args opts) args))))) 1190 (cons args (if restp nil (if opts (+ args opts) args))))))
1129 1191
1130 1192
1131(defun byte-compile-arglist-signatures-congruent-p (old new) 1193(defun byte-compile-arglist-signatures-congruent-p (old new)
@@ -1244,7 +1306,7 @@ extra args."
1244 (custom-declare-variable . defcustom)))) 1306 (custom-declare-variable . defcustom))))
1245 (cadr name))) 1307 (cadr name)))
1246 ;; Update the current group, if needed. 1308 ;; Update the current group, if needed.
1247 (if (and byte-compile-current-file ;Only when byte-compiling a whole file. 1309 (if (and byte-compile-current-file ;Only when compiling a whole file.
1248 (eq (car form) 'custom-declare-group) 1310 (eq (car form) 'custom-declare-group)
1249 (eq (car-safe name) 'quote)) 1311 (eq (car-safe name) 'quote))
1250 (setq byte-compile-current-group (cadr name)))))) 1312 (setq byte-compile-current-group (cadr name))))))
@@ -1252,50 +1314,54 @@ extra args."
1252;; Warn if the function or macro is being redefined with a different 1314;; Warn if the function or macro is being redefined with a different
1253;; number of arguments. 1315;; number of arguments.
1254(defun byte-compile-arglist-warn (form macrop) 1316(defun byte-compile-arglist-warn (form macrop)
1255 (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) 1317 (let* ((name (nth 1 form))
1318 (old (byte-compile-fdefinition name macrop)))
1256 (if (and old (not (eq old t))) 1319 (if (and old (not (eq old t)))
1257 (progn 1320 (progn
1258 (and (eq 'macro (car-safe old)) 1321 (and (eq 'macro (car-safe old))
1259 (eq 'lambda (car-safe (cdr-safe old))) 1322 (eq 'lambda (car-safe (cdr-safe old)))
1260 (setq old (cdr old))) 1323 (setq old (cdr old)))
1261 (let ((sig1 (byte-compile-arglist-signature 1324 (let ((sig1 (byte-compile-arglist-signature
1262 (if (eq 'lambda (car-safe old)) 1325 (pcase old
1263 (nth 1 old) 1326 (`(lambda ,args . ,_) args)
1264 (if (byte-code-function-p old) 1327 (`(closure ,_ ,args . ,_) args)
1265 (aref old 0) 1328 ((pred byte-code-function-p) (aref old 0))
1266 '(&rest def))))) 1329 (t '(&rest def)))))
1267 (sig2 (byte-compile-arglist-signature (nth 2 form)))) 1330 (sig2 (byte-compile-arglist-signature (nth 2 form))))
1268 (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) 1331 (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
1269 (byte-compile-set-symbol-position (nth 1 form)) 1332 (byte-compile-set-symbol-position name)
1270 (byte-compile-warn 1333 (byte-compile-warn
1271 "%s %s used to take %s %s, now takes %s" 1334 "%s %s used to take %s %s, now takes %s"
1272 (if (eq (car form) 'defun) "function" "macro") 1335 (if (eq (car form) 'defun) "function" "macro")
1273 (nth 1 form) 1336 name
1274 (byte-compile-arglist-signature-string sig1) 1337 (byte-compile-arglist-signature-string sig1)
1275 (if (equal sig1 '(1 . 1)) "argument" "arguments") 1338 (if (equal sig1 '(1 . 1)) "argument" "arguments")
1276 (byte-compile-arglist-signature-string sig2))))) 1339 (byte-compile-arglist-signature-string sig2)))))
1277 ;; This is the first definition. See if previous calls are compatible. 1340 ;; This is the first definition. See if previous calls are compatible.
1278 (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) 1341 (let ((calls (assq name byte-compile-unresolved-functions))
1279 nums sig min max) 1342 nums sig min max)
1280 (if calls 1343 (when calls
1281 (progn 1344 (when (and (symbolp name)
1282 (setq sig (byte-compile-arglist-signature (nth 2 form)) 1345 (eq (get name 'byte-optimizer)
1283 nums (sort (copy-sequence (cdr calls)) (function <)) 1346 'byte-compile-inline-expand))
1284 min (car nums) 1347 (byte-compile-warn "defsubst `%s' was used before it was defined"
1285 max (car (nreverse nums))) 1348 name))
1286 (when (or (< min (car sig)) 1349 (setq sig (byte-compile-arglist-signature (nth 2 form))
1287 (and (cdr sig) (> max (cdr sig)))) 1350 nums (sort (copy-sequence (cdr calls)) (function <))
1288 (byte-compile-set-symbol-position (nth 1 form)) 1351 min (car nums)
1289 (byte-compile-warn 1352 max (car (nreverse nums)))
1290 "%s being defined to take %s%s, but was previously called with %s" 1353 (when (or (< min (car sig))
1291 (nth 1 form) 1354 (and (cdr sig) (> max (cdr sig))))
1292 (byte-compile-arglist-signature-string sig) 1355 (byte-compile-set-symbol-position name)
1293 (if (equal sig '(1 . 1)) " arg" " args") 1356 (byte-compile-warn
1294 (byte-compile-arglist-signature-string (cons min max)))) 1357 "%s being defined to take %s%s, but was previously called with %s"
1295 1358 name
1296 (setq byte-compile-unresolved-functions 1359 (byte-compile-arglist-signature-string sig)
1297 (delq calls byte-compile-unresolved-functions))))) 1360 (if (equal sig '(1 . 1)) " arg" " args")
1298 ))) 1361 (byte-compile-arglist-signature-string (cons min max))))
1362
1363 (setq byte-compile-unresolved-functions
1364 (delq calls byte-compile-unresolved-functions)))))))
1299 1365
1300(defvar byte-compile-cl-functions nil 1366(defvar byte-compile-cl-functions nil
1301 "List of functions defined in CL.") 1367 "List of functions defined in CL.")
@@ -1331,14 +1397,7 @@ extra args."
1331 ;; but such warnings are never useful, 1397 ;; but such warnings are never useful,
1332 ;; so don't warn about them. 1398 ;; so don't warn about them.
1333 macroexpand cl-macroexpand-all 1399 macroexpand cl-macroexpand-all
1334 cl-compiling-file))) 1400 cl-compiling-file))))
1335 ;; Avoid warnings for things which are safe because they
1336 ;; have suitable compiler macros, but those aren't
1337 ;; expanded at this stage. There should probably be more
1338 ;; here than caaar and friends.
1339 (not (and (eq (get func 'byte-compile)
1340 'cl-byte-compile-compiler-macro)
1341 (string-match "\\`c[ad]+r\\'" (symbol-name func)))))
1342 (byte-compile-warn "function `%s' from cl package called at runtime" 1401 (byte-compile-warn "function `%s' from cl package called at runtime"
1343 func))) 1402 func)))
1344 form) 1403 form)
@@ -1401,7 +1460,7 @@ symbol itself."
1401 (if any-value 1460 (if any-value
1402 (or (memq symbol byte-compile-const-variables) 1461 (or (memq symbol byte-compile-const-variables)
1403 ;; FIXME: We should provide a less intrusive way to find out 1462 ;; FIXME: We should provide a less intrusive way to find out
1404 ;; is a variable is "constant". 1463 ;; if a variable is "constant".
1405 (and (boundp symbol) 1464 (and (boundp symbol)
1406 (condition-case nil 1465 (condition-case nil
1407 (progn (set symbol (symbol-value symbol)) nil) 1466 (progn (set symbol (symbol-value symbol)) nil)
@@ -1414,6 +1473,7 @@ symbol itself."
1414 ((byte-compile-const-symbol-p ,form)))) 1473 ((byte-compile-const-symbol-p ,form))))
1415 1474
1416(defmacro byte-compile-close-variables (&rest body) 1475(defmacro byte-compile-close-variables (&rest body)
1476 (declare (debug t))
1417 (cons 'let 1477 (cons 'let
1418 (cons '(;; 1478 (cons '(;;
1419 ;; Close over these variables to encapsulate the 1479 ;; Close over these variables to encapsulate the
@@ -1444,6 +1504,7 @@ symbol itself."
1444 body))) 1504 body)))
1445 1505
1446(defmacro displaying-byte-compile-warnings (&rest body) 1506(defmacro displaying-byte-compile-warnings (&rest body)
1507 (declare (debug t))
1447 `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) 1508 `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
1448 (warning-series-started 1509 (warning-series-started
1449 (and (markerp warning-series) 1510 (and (markerp warning-series)
@@ -1481,41 +1542,33 @@ Files in subdirectories of DIRECTORY are processed also."
1481 (interactive "DByte force recompile (directory): ") 1542 (interactive "DByte force recompile (directory): ")
1482 (byte-recompile-directory directory nil t)) 1543 (byte-recompile-directory directory nil t))
1483 1544
1484;; The `bytecomp-' prefix is applied to all local variables with
1485;; otherwise common names in this and similar functions for the sake
1486;; of the boundp test in byte-compile-variable-ref.
1487;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html
1488;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html
1489;; Note that similar considerations apply to command-line-1 in startup.el.
1490;;;###autoload 1545;;;###autoload
1491(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg 1546(defun byte-recompile-directory (directory &optional arg force)
1492 bytecomp-force) 1547 "Recompile every `.el' file in DIRECTORY that needs recompilation.
1493 "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation.
1494This happens when a `.elc' file exists but is older than the `.el' file. 1548This happens when a `.elc' file exists but is older than the `.el' file.
1495Files in subdirectories of BYTECOMP-DIRECTORY are processed also. 1549Files in subdirectories of DIRECTORY are processed also.
1496 1550
1497If the `.elc' file does not exist, normally this function *does not* 1551If the `.elc' file does not exist, normally this function *does not*
1498compile the corresponding `.el' file. However, if the prefix argument 1552compile the corresponding `.el' file. However, if the prefix argument
1499BYTECOMP-ARG is 0, that means do compile all those files. A nonzero 1553ARG is 0, that means do compile all those files. A nonzero
1500BYTECOMP-ARG means ask the user, for each such `.el' file, whether to 1554ARG means ask the user, for each such `.el' file, whether to
1501compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory 1555compile it. A nonzero ARG also means ask about each subdirectory
1502before scanning it. 1556before scanning it.
1503 1557
1504If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file 1558If the third argument FORCE is non-nil, recompile every `.el' file
1505that already has a `.elc' file." 1559that already has a `.elc' file."
1506 (interactive "DByte recompile directory: \nP") 1560 (interactive "DByte recompile directory: \nP")
1507 (if bytecomp-arg 1561 (if arg (setq arg (prefix-numeric-value arg)))
1508 (setq bytecomp-arg (prefix-numeric-value bytecomp-arg)))
1509 (if noninteractive 1562 (if noninteractive
1510 nil 1563 nil
1511 (save-some-buffers) 1564 (save-some-buffers)
1512 (force-mode-line-update)) 1565 (force-mode-line-update))
1513 (with-current-buffer (get-buffer-create byte-compile-log-buffer) 1566 (with-current-buffer (get-buffer-create byte-compile-log-buffer)
1514 (setq default-directory (expand-file-name bytecomp-directory)) 1567 (setq default-directory (expand-file-name directory))
1515 ;; compilation-mode copies value of default-directory. 1568 ;; compilation-mode copies value of default-directory.
1516 (unless (eq major-mode 'compilation-mode) 1569 (unless (eq major-mode 'compilation-mode)
1517 (compilation-mode)) 1570 (compilation-mode))
1518 (let ((bytecomp-directories (list default-directory)) 1571 (let ((directories (list default-directory))
1519 (default-directory default-directory) 1572 (default-directory default-directory)
1520 (skip-count 0) 1573 (skip-count 0)
1521 (fail-count 0) 1574 (fail-count 0)
@@ -1523,47 +1576,36 @@ that already has a `.elc' file."
1523 (dir-count 0) 1576 (dir-count 0)
1524 last-dir) 1577 last-dir)
1525 (displaying-byte-compile-warnings 1578 (displaying-byte-compile-warnings
1526 (while bytecomp-directories 1579 (while directories
1527 (setq bytecomp-directory (car bytecomp-directories)) 1580 (setq directory (car directories))
1528 (message "Checking %s..." bytecomp-directory) 1581 (message "Checking %s..." directory)
1529 (let ((bytecomp-files (directory-files bytecomp-directory)) 1582 (dolist (file (directory-files directory))
1530 bytecomp-source bytecomp-dest) 1583 (let ((source (expand-file-name file directory)))
1531 (dolist (bytecomp-file bytecomp-files) 1584 (if (and (not (member file '("RCS" "CVS")))
1532 (setq bytecomp-source 1585 (not (eq ?\. (aref file 0)))
1533 (expand-file-name bytecomp-file bytecomp-directory)) 1586 (file-directory-p source)
1534 (if (and (not (member bytecomp-file '("RCS" "CVS"))) 1587 (not (file-symlink-p source)))
1535 (not (eq ?\. (aref bytecomp-file 0))) 1588 ;; This file is a subdirectory. Handle them differently.
1536 (file-directory-p bytecomp-source) 1589 (when (or (null arg) (eq 0 arg)
1537 (not (file-symlink-p bytecomp-source))) 1590 (y-or-n-p (concat "Check " source "? ")))
1538 ;; This file is a subdirectory. Handle them differently. 1591 (setq directories (nconc directories (list source))))
1539 (when (or (null bytecomp-arg) 1592 ;; It is an ordinary file. Decide whether to compile it.
1540 (eq 0 bytecomp-arg) 1593 (if (and (string-match emacs-lisp-file-regexp source)
1541 (y-or-n-p (concat "Check " bytecomp-source "? "))) 1594 (file-readable-p source)
1542 (setq bytecomp-directories 1595 (not (auto-save-file-name-p source))
1543 (nconc bytecomp-directories (list bytecomp-source)))) 1596 (not (string-equal dir-locals-file
1544 ;; It is an ordinary file. Decide whether to compile it. 1597 (file-name-nondirectory source))))
1545 (if (and (string-match emacs-lisp-file-regexp bytecomp-source) 1598 (progn (case (byte-recompile-file source force arg)
1546 (file-readable-p bytecomp-source) 1599 (no-byte-compile (setq skip-count (1+ skip-count)))
1547 (not (auto-save-file-name-p bytecomp-source)) 1600 ((t) (setq file-count (1+ file-count)))
1548 (not (string-equal dir-locals-file 1601 ((nil) (setq fail-count (1+ fail-count))))
1549 (file-name-nondirectory 1602 (or noninteractive
1550 bytecomp-source)))) 1603 (message "Checking %s..." directory))
1551 (progn (let ((bytecomp-res (byte-recompile-file 1604 (if (not (eq last-dir directory))
1552 bytecomp-source 1605 (setq last-dir directory
1553 bytecomp-force bytecomp-arg))) 1606 dir-count (1+ dir-count)))
1554 (cond ((eq bytecomp-res 'no-byte-compile) 1607 )))))
1555 (setq skip-count (1+ skip-count))) 1608 (setq directories (cdr directories))))
1556 ((eq bytecomp-res t)
1557 (setq file-count (1+ file-count)))
1558 ((eq bytecomp-res nil)
1559 (setq fail-count (1+ fail-count)))))
1560 (or noninteractive
1561 (message "Checking %s..." bytecomp-directory))
1562 (if (not (eq last-dir bytecomp-directory))
1563 (setq last-dir bytecomp-directory
1564 dir-count (1+ dir-count)))
1565 )))))
1566 (setq bytecomp-directories (cdr bytecomp-directories))))
1567 (message "Done (Total of %d file%s compiled%s%s%s)" 1609 (message "Done (Total of %d file%s compiled%s%s%s)"
1568 file-count (if (= file-count 1) "" "s") 1610 file-count (if (= file-count 1) "" "s")
1569 (if (> fail-count 0) (format ", %d failed" fail-count) "") 1611 (if (> fail-count 0) (format ", %d failed" fail-count) "")
@@ -1575,104 +1617,100 @@ that already has a `.elc' file."
1575 "Non-nil to prevent byte-compiling of Emacs Lisp code. 1617 "Non-nil to prevent byte-compiling of Emacs Lisp code.
1576This is normally set in local file variables at the end of the elisp file: 1618This is normally set in local file variables at the end of the elisp file:
1577 1619
1578;; Local Variables:\n;; no-byte-compile: t\n;; End: ") 1620\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main.
1579;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) 1621;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp)
1580 1622
1581(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) 1623(defun byte-recompile-file (filename &optional force arg load)
1582 "Recompile BYTECOMP-FILENAME file if it needs recompilation. 1624 "Recompile FILENAME file if it needs recompilation.
1583This happens when its `.elc' file is older than itself. 1625This happens when its `.elc' file is older than itself.
1584 1626
1585If the `.elc' file exists and is up-to-date, normally this 1627If the `.elc' file exists and is up-to-date, normally this
1586function *does not* compile BYTECOMP-FILENAME. However, if the 1628function *does not* compile FILENAME. However, if the
1587prefix argument BYTECOMP-FORCE is set, that means do compile 1629prefix argument FORCE is set, that means do compile
1588BYTECOMP-FILENAME even if the destination already exists and is 1630FILENAME even if the destination already exists and is
1589up-to-date. 1631up-to-date.
1590 1632
1591If the `.elc' file does not exist, normally this function *does 1633If the `.elc' file does not exist, normally this function *does
1592not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means 1634not* compile FILENAME. If ARG is 0, that means
1593compile the file even if it has never been compiled before. 1635compile the file even if it has never been compiled before.
1594A nonzero BYTECOMP-ARG means ask the user. 1636A nonzero ARG means ask the user.
1595 1637
1596If LOAD is set, `load' the file after compiling. 1638If LOAD is set, `load' the file after compiling.
1597 1639
1598The value returned is the value returned by `byte-compile-file', 1640The value returned is the value returned by `byte-compile-file',
1599or 'no-byte-compile if the file did not need recompilation." 1641or 'no-byte-compile if the file did not need recompilation."
1600 (interactive 1642 (interactive
1601 (let ((bytecomp-file buffer-file-name) 1643 (let ((file buffer-file-name)
1602 (bytecomp-file-name nil) 1644 (file-name nil)
1603 (bytecomp-file-dir nil)) 1645 (file-dir nil))
1604 (and bytecomp-file 1646 (and file
1605 (eq (cdr (assq 'major-mode (buffer-local-variables))) 1647 (derived-mode-p 'emacs-lisp-mode)
1606 'emacs-lisp-mode) 1648 (setq file-name (file-name-nondirectory file)
1607 (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) 1649 file-dir (file-name-directory file)))
1608 bytecomp-file-dir (file-name-directory bytecomp-file)))
1609 (list (read-file-name (if current-prefix-arg 1650 (list (read-file-name (if current-prefix-arg
1610 "Byte compile file: " 1651 "Byte compile file: "
1611 "Byte recompile file: ") 1652 "Byte recompile file: ")
1612 bytecomp-file-dir bytecomp-file-name nil) 1653 file-dir file-name nil)
1613 current-prefix-arg))) 1654 current-prefix-arg)))
1614 (let ((bytecomp-dest 1655 (let ((dest (byte-compile-dest-file filename))
1615 (byte-compile-dest-file bytecomp-filename))
1616 ;; Expand now so we get the current buffer's defaults 1656 ;; Expand now so we get the current buffer's defaults
1617 (bytecomp-filename (expand-file-name bytecomp-filename))) 1657 (filename (expand-file-name filename)))
1618 (if (if (file-exists-p bytecomp-dest) 1658 (if (if (file-exists-p dest)
1619 ;; File was already compiled 1659 ;; File was already compiled
1620 ;; Compile if forced to, or filename newer 1660 ;; Compile if forced to, or filename newer
1621 (or bytecomp-force 1661 (or force
1622 (file-newer-than-file-p bytecomp-filename 1662 (file-newer-than-file-p filename dest))
1623 bytecomp-dest)) 1663 (and arg
1624 (and bytecomp-arg 1664 (or (eq 0 arg)
1625 (or (eq 0 bytecomp-arg)
1626 (y-or-n-p (concat "Compile " 1665 (y-or-n-p (concat "Compile "
1627 bytecomp-filename "? "))))) 1666 filename "? ")))))
1628 (progn 1667 (progn
1629 (if (and noninteractive (not byte-compile-verbose)) 1668 (if (and noninteractive (not byte-compile-verbose))
1630 (message "Compiling %s..." bytecomp-filename)) 1669 (message "Compiling %s..." filename))
1631 (byte-compile-file bytecomp-filename load)) 1670 (byte-compile-file filename load))
1632 (when load (load bytecomp-filename)) 1671 (when load (load filename))
1633 'no-byte-compile))) 1672 'no-byte-compile)))
1634 1673
1635;;;###autoload 1674;;;###autoload
1636(defun byte-compile-file (bytecomp-filename &optional load) 1675(defun byte-compile-file (filename &optional load)
1637 "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. 1676 "Compile a file of Lisp code named FILENAME into a file of byte code.
1638The output file's name is generated by passing BYTECOMP-FILENAME to the 1677The output file's name is generated by passing FILENAME to the
1639function `byte-compile-dest-file' (which see). 1678function `byte-compile-dest-file' (which see).
1640With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. 1679With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling.
1641The value is non-nil if there were no errors, nil if errors." 1680The value is non-nil if there were no errors, nil if errors."
1642;; (interactive "fByte compile file: \nP") 1681;; (interactive "fByte compile file: \nP")
1643 (interactive 1682 (interactive
1644 (let ((bytecomp-file buffer-file-name) 1683 (let ((file buffer-file-name)
1645 (bytecomp-file-name nil) 1684 (file-name nil)
1646 (bytecomp-file-dir nil)) 1685 (file-dir nil))
1647 (and bytecomp-file 1686 (and file
1648 (eq (cdr (assq 'major-mode (buffer-local-variables))) 1687 (derived-mode-p 'emacs-lisp-mode)
1649 'emacs-lisp-mode) 1688 (setq file-name (file-name-nondirectory file)
1650 (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) 1689 file-dir (file-name-directory file)))
1651 bytecomp-file-dir (file-name-directory bytecomp-file)))
1652 (list (read-file-name (if current-prefix-arg 1690 (list (read-file-name (if current-prefix-arg
1653 "Byte compile and load file: " 1691 "Byte compile and load file: "
1654 "Byte compile file: ") 1692 "Byte compile file: ")
1655 bytecomp-file-dir bytecomp-file-name nil) 1693 file-dir file-name nil)
1656 current-prefix-arg))) 1694 current-prefix-arg)))
1657 ;; Expand now so we get the current buffer's defaults 1695 ;; Expand now so we get the current buffer's defaults
1658 (setq bytecomp-filename (expand-file-name bytecomp-filename)) 1696 (setq filename (expand-file-name filename))
1659 1697
1660 ;; If we're compiling a file that's in a buffer and is modified, offer 1698 ;; If we're compiling a file that's in a buffer and is modified, offer
1661 ;; to save it first. 1699 ;; to save it first.
1662 (or noninteractive 1700 (or noninteractive
1663 (let ((b (get-file-buffer (expand-file-name bytecomp-filename)))) 1701 (let ((b (get-file-buffer (expand-file-name filename))))
1664 (if (and b (buffer-modified-p b) 1702 (if (and b (buffer-modified-p b)
1665 (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) 1703 (y-or-n-p (format "Save buffer %s first? " (buffer-name b))))
1666 (with-current-buffer b (save-buffer))))) 1704 (with-current-buffer b (save-buffer)))))
1667 1705
1668 ;; Force logging of the file name for each file compiled. 1706 ;; Force logging of the file name for each file compiled.
1669 (setq byte-compile-last-logged-file nil) 1707 (setq byte-compile-last-logged-file nil)
1670 (let ((byte-compile-current-file bytecomp-filename) 1708 (let ((byte-compile-current-file filename)
1671 (byte-compile-current-group nil) 1709 (byte-compile-current-group nil)
1672 (set-auto-coding-for-load t) 1710 (set-auto-coding-for-load t)
1673 target-file input-buffer output-buffer 1711 target-file input-buffer output-buffer
1674 byte-compile-dest-file) 1712 byte-compile-dest-file)
1675 (setq target-file (byte-compile-dest-file bytecomp-filename)) 1713 (setq target-file (byte-compile-dest-file filename))
1676 (setq byte-compile-dest-file target-file) 1714 (setq byte-compile-dest-file target-file)
1677 (with-current-buffer 1715 (with-current-buffer
1678 (setq input-buffer (get-buffer-create " *Compiler Input*")) 1716 (setq input-buffer (get-buffer-create " *Compiler Input*"))
@@ -1681,7 +1719,7 @@ The value is non-nil if there were no errors, nil if errors."
1681 ;; Always compile an Emacs Lisp file as multibyte 1719 ;; Always compile an Emacs Lisp file as multibyte
1682 ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- 1720 ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
1683 (set-buffer-multibyte t) 1721 (set-buffer-multibyte t)
1684 (insert-file-contents bytecomp-filename) 1722 (insert-file-contents filename)
1685 ;; Mimic the way after-insert-file-set-coding can make the 1723 ;; Mimic the way after-insert-file-set-coding can make the
1686 ;; buffer unibyte when visiting this file. 1724 ;; buffer unibyte when visiting this file.
1687 (when (or (eq last-coding-system-used 'no-conversion) 1725 (when (or (eq last-coding-system-used 'no-conversion)
@@ -1691,7 +1729,7 @@ The value is non-nil if there were no errors, nil if errors."
1691 (set-buffer-multibyte nil)) 1729 (set-buffer-multibyte nil))
1692 ;; Run hooks including the uncompression hook. 1730 ;; Run hooks including the uncompression hook.
1693 ;; If they change the file name, then change it for the output also. 1731 ;; If they change the file name, then change it for the output also.
1694 (letf ((buffer-file-name bytecomp-filename) 1732 (letf ((buffer-file-name filename)
1695 ((default-value 'major-mode) 'emacs-lisp-mode) 1733 ((default-value 'major-mode) 'emacs-lisp-mode)
1696 ;; Ignore unsafe local variables. 1734 ;; Ignore unsafe local variables.
1697 ;; We only care about a few of them for our purposes. 1735 ;; We only care about a few of them for our purposes.
@@ -1699,15 +1737,15 @@ The value is non-nil if there were no errors, nil if errors."
1699 (enable-local-eval nil)) 1737 (enable-local-eval nil))
1700 ;; Arg of t means don't alter enable-local-variables. 1738 ;; Arg of t means don't alter enable-local-variables.
1701 (normal-mode t) 1739 (normal-mode t)
1702 (setq bytecomp-filename buffer-file-name)) 1740 (setq filename buffer-file-name))
1703 ;; Set the default directory, in case an eval-when-compile uses it. 1741 ;; Set the default directory, in case an eval-when-compile uses it.
1704 (setq default-directory (file-name-directory bytecomp-filename))) 1742 (setq default-directory (file-name-directory filename)))
1705 ;; Check if the file's local variables explicitly specify not to 1743 ;; Check if the file's local variables explicitly specify not to
1706 ;; compile this file. 1744 ;; compile this file.
1707 (if (with-current-buffer input-buffer no-byte-compile) 1745 (if (with-current-buffer input-buffer no-byte-compile)
1708 (progn 1746 (progn
1709 ;; (message "%s not compiled because of `no-byte-compile: %s'" 1747 ;; (message "%s not compiled because of `no-byte-compile: %s'"
1710 ;; (file-relative-name bytecomp-filename) 1748 ;; (file-relative-name filename)
1711 ;; (with-current-buffer input-buffer no-byte-compile)) 1749 ;; (with-current-buffer input-buffer no-byte-compile))
1712 (when (file-exists-p target-file) 1750 (when (file-exists-p target-file)
1713 (message "%s deleted because of `no-byte-compile: %s'" 1751 (message "%s deleted because of `no-byte-compile: %s'"
@@ -1717,18 +1755,18 @@ The value is non-nil if there were no errors, nil if errors."
1717 ;; We successfully didn't compile this file. 1755 ;; We successfully didn't compile this file.
1718 'no-byte-compile) 1756 'no-byte-compile)
1719 (when byte-compile-verbose 1757 (when byte-compile-verbose
1720 (message "Compiling %s..." bytecomp-filename)) 1758 (message "Compiling %s..." filename))
1721 (setq byte-compiler-error-flag nil) 1759 (setq byte-compiler-error-flag nil)
1722 ;; It is important that input-buffer not be current at this call, 1760 ;; It is important that input-buffer not be current at this call,
1723 ;; so that the value of point set in input-buffer 1761 ;; so that the value of point set in input-buffer
1724 ;; within byte-compile-from-buffer lingers in that buffer. 1762 ;; within byte-compile-from-buffer lingers in that buffer.
1725 (setq output-buffer 1763 (setq output-buffer
1726 (save-current-buffer 1764 (save-current-buffer
1727 (byte-compile-from-buffer input-buffer bytecomp-filename))) 1765 (byte-compile-from-buffer input-buffer)))
1728 (if byte-compiler-error-flag 1766 (if byte-compiler-error-flag
1729 nil 1767 nil
1730 (when byte-compile-verbose 1768 (when byte-compile-verbose
1731 (message "Compiling %s...done" bytecomp-filename)) 1769 (message "Compiling %s...done" filename))
1732 (kill-buffer input-buffer) 1770 (kill-buffer input-buffer)
1733 (with-current-buffer output-buffer 1771 (with-current-buffer output-buffer
1734 (goto-char (point-max)) 1772 (goto-char (point-max))
@@ -1768,9 +1806,9 @@ The value is non-nil if there were no errors, nil if errors."
1768 (if (and byte-compile-generate-call-tree 1806 (if (and byte-compile-generate-call-tree
1769 (or (eq t byte-compile-generate-call-tree) 1807 (or (eq t byte-compile-generate-call-tree)
1770 (y-or-n-p (format "Report call tree for %s? " 1808 (y-or-n-p (format "Report call tree for %s? "
1771 bytecomp-filename)))) 1809 filename))))
1772 (save-excursion 1810 (save-excursion
1773 (display-call-tree bytecomp-filename))) 1811 (display-call-tree filename)))
1774 (if load 1812 (if load
1775 (load target-file)) 1813 (load target-file))
1776 t)))) 1814 t))))
@@ -1794,18 +1832,21 @@ With argument ARG, insert value in current buffer after the form."
1794 (let ((read-with-symbol-positions (current-buffer)) 1832 (let ((read-with-symbol-positions (current-buffer))
1795 (read-symbol-positions-list nil)) 1833 (read-symbol-positions-list nil))
1796 (displaying-byte-compile-warnings 1834 (displaying-byte-compile-warnings
1797 (byte-compile-sexp (read (current-buffer)))))))) 1835 (byte-compile-sexp (read (current-buffer)))))
1836 lexical-binding)))
1798 (cond (arg 1837 (cond (arg
1799 (message "Compiling from buffer... done.") 1838 (message "Compiling from buffer... done.")
1800 (prin1 value (current-buffer)) 1839 (prin1 value (current-buffer))
1801 (insert "\n")) 1840 (insert "\n"))
1802 ((message "%s" (prin1-to-string value))))))) 1841 ((message "%s" (prin1-to-string value)))))))
1803 1842
1843;; Dynamically bound in byte-compile-from-buffer.
1844;; NB also used in cl.el and cl-macs.el.
1845(defvar byte-compile--outbuffer)
1804 1846
1805(defun byte-compile-from-buffer (bytecomp-inbuffer &optional bytecomp-filename) 1847(defun byte-compile-from-buffer (inbuffer)
1806 ;; Filename is used for the loading-into-Emacs-18 error message. 1848 (let (byte-compile--outbuffer
1807 (let (bytecomp-outbuffer 1849 (byte-compile-current-buffer inbuffer)
1808 (byte-compile-current-buffer bytecomp-inbuffer)
1809 (byte-compile-read-position nil) 1850 (byte-compile-read-position nil)
1810 (byte-compile-last-position nil) 1851 (byte-compile-last-position nil)
1811 ;; Prevent truncation of flonums and lists as we read and print them 1852 ;; Prevent truncation of flonums and lists as we read and print them
@@ -1826,22 +1867,24 @@ With argument ARG, insert value in current buffer after the form."
1826 (byte-compile-output nil) 1867 (byte-compile-output nil)
1827 ;; This allows us to get the positions of symbols read; it's 1868 ;; This allows us to get the positions of symbols read; it's
1828 ;; new in Emacs 22.1. 1869 ;; new in Emacs 22.1.
1829 (read-with-symbol-positions bytecomp-inbuffer) 1870 (read-with-symbol-positions inbuffer)
1830 (read-symbol-positions-list nil) 1871 (read-symbol-positions-list nil)
1831 ;; #### This is bound in b-c-close-variables. 1872 ;; #### This is bound in b-c-close-variables.
1832 ;; (byte-compile-warnings byte-compile-warnings) 1873 ;; (byte-compile-warnings byte-compile-warnings)
1833 ) 1874 )
1834 (byte-compile-close-variables 1875 (byte-compile-close-variables
1835 (with-current-buffer 1876 (with-current-buffer
1836 (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*")) 1877 (setq byte-compile--outbuffer
1878 (get-buffer-create " *Compiler Output*"))
1837 (set-buffer-multibyte t) 1879 (set-buffer-multibyte t)
1838 (erase-buffer) 1880 (erase-buffer)
1839 ;; (emacs-lisp-mode) 1881 ;; (emacs-lisp-mode)
1840 (setq case-fold-search nil)) 1882 (setq case-fold-search nil))
1841 (displaying-byte-compile-warnings 1883 (displaying-byte-compile-warnings
1842 (with-current-buffer bytecomp-inbuffer 1884 (with-current-buffer inbuffer
1843 (and bytecomp-filename 1885 (and byte-compile-current-file
1844 (byte-compile-insert-header bytecomp-filename bytecomp-outbuffer)) 1886 (byte-compile-insert-header byte-compile-current-file
1887 byte-compile--outbuffer))
1845 (goto-char (point-min)) 1888 (goto-char (point-min))
1846 ;; Should we always do this? When calling multiple files, it 1889 ;; Should we always do this? When calling multiple files, it
1847 ;; would be useful to delay this warning until all have been 1890 ;; would be useful to delay this warning until all have been
@@ -1858,13 +1901,13 @@ With argument ARG, insert value in current buffer after the form."
1858 (setq byte-compile-read-position (point) 1901 (setq byte-compile-read-position (point)
1859 byte-compile-last-position byte-compile-read-position) 1902 byte-compile-last-position byte-compile-read-position)
1860 (let* ((old-style-backquotes nil) 1903 (let* ((old-style-backquotes nil)
1861 (form (read bytecomp-inbuffer))) 1904 (form (read inbuffer)))
1862 ;; Warn about the use of old-style backquotes. 1905 ;; Warn about the use of old-style backquotes.
1863 (when old-style-backquotes 1906 (when old-style-backquotes
1864 (byte-compile-warn "!! The file uses old-style backquotes !! 1907 (byte-compile-warn "!! The file uses old-style backquotes !!
1865This functionality has been obsolete for more than 10 years already 1908This functionality has been obsolete for more than 10 years already
1866and will be removed soon. See (elisp)Backquote in the manual.")) 1909and will be removed soon. See (elisp)Backquote in the manual."))
1867 (byte-compile-file-form form))) 1910 (byte-compile-toplevel-file-form form)))
1868 ;; Compile pending forms at end of file. 1911 ;; Compile pending forms at end of file.
1869 (byte-compile-flush-pending) 1912 (byte-compile-flush-pending)
1870 ;; Make warnings about unresolved functions 1913 ;; Make warnings about unresolved functions
@@ -1873,10 +1916,10 @@ and will be removed soon. See (elisp)Backquote in the manual."))
1873 (byte-compile-warn-about-unresolved-functions)) 1916 (byte-compile-warn-about-unresolved-functions))
1874 ;; Fix up the header at the front of the output 1917 ;; Fix up the header at the front of the output
1875 ;; if the buffer contains multibyte characters. 1918 ;; if the buffer contains multibyte characters.
1876 (and bytecomp-filename 1919 (and byte-compile-current-file
1877 (with-current-buffer bytecomp-outbuffer 1920 (with-current-buffer byte-compile--outbuffer
1878 (byte-compile-fix-header bytecomp-filename))))) 1921 (byte-compile-fix-header byte-compile-current-file)))))
1879 bytecomp-outbuffer)) 1922 byte-compile--outbuffer))
1880 1923
1881(defun byte-compile-fix-header (filename) 1924(defun byte-compile-fix-header (filename)
1882 "If the current buffer has any multibyte characters, insert a version test." 1925 "If the current buffer has any multibyte characters, insert a version test."
@@ -1964,10 +2007,6 @@ Call from the source buffer."
1964 ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" 2007 ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
1965 ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) 2008 ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))))
1966 2009
1967;; Dynamically bound in byte-compile-from-buffer.
1968;; NB also used in cl.el and cl-macs.el.
1969(defvar bytecomp-outbuffer)
1970
1971(defun byte-compile-output-file-form (form) 2010(defun byte-compile-output-file-form (form)
1972 ;; writes the given form to the output buffer, being careful of docstrings 2011 ;; writes the given form to the output buffer, being careful of docstrings
1973 ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and 2012 ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and
@@ -1975,8 +2014,8 @@ Call from the source buffer."
1975 ;; defalias calls are output directly by byte-compile-file-form-defmumble; 2014 ;; defalias calls are output directly by byte-compile-file-form-defmumble;
1976 ;; it does not pay to first build the defalias in defmumble and then parse 2015 ;; it does not pay to first build the defalias in defmumble and then parse
1977 ;; it here. 2016 ;; it here.
1978 (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst autoload 2017 (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst
1979 custom-declare-variable)) 2018 autoload custom-declare-variable))
1980 (stringp (nth 3 form))) 2019 (stringp (nth 3 form)))
1981 (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil 2020 (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
1982 (memq (car form) 2021 (memq (car form)
@@ -1989,11 +2028,12 @@ Call from the source buffer."
1989 (print-gensym t) 2028 (print-gensym t)
1990 (print-circle ; handle circular data structures 2029 (print-circle ; handle circular data structures
1991 (not byte-compile-disable-print-circle))) 2030 (not byte-compile-disable-print-circle)))
1992 (princ "\n" bytecomp-outbuffer) 2031 (princ "\n" byte-compile--outbuffer)
1993 (prin1 form bytecomp-outbuffer) 2032 (prin1 form byte-compile--outbuffer)
1994 nil))) 2033 nil)))
1995 2034
1996(defvar print-gensym-alist) ;Used before print-circle existed. 2035(defvar print-gensym-alist) ;Used before print-circle existed.
2036(defvar byte-compile--for-effect)
1997 2037
1998(defun byte-compile-output-docform (preface name info form specindex quoted) 2038(defun byte-compile-output-docform (preface name info form specindex quoted)
1999 "Print a form with a doc string. INFO is (prefix doc-index postfix). 2039 "Print a form with a doc string. INFO is (prefix doc-index postfix).
@@ -2009,7 +2049,7 @@ list that represents a doc string reference.
2009 ;; We need to examine byte-compile-dynamic-docstrings 2049 ;; We need to examine byte-compile-dynamic-docstrings
2010 ;; in the input buffer (now current), not in the output buffer. 2050 ;; in the input buffer (now current), not in the output buffer.
2011 (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) 2051 (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
2012 (with-current-buffer bytecomp-outbuffer 2052 (with-current-buffer byte-compile--outbuffer
2013 (let (position) 2053 (let (position)
2014 2054
2015 ;; Insert the doc string, and make it a comment with #@LENGTH. 2055 ;; Insert the doc string, and make it a comment with #@LENGTH.
@@ -2033,7 +2073,7 @@ list that represents a doc string reference.
2033 (if preface 2073 (if preface
2034 (progn 2074 (progn
2035 (insert preface) 2075 (insert preface)
2036 (prin1 name bytecomp-outbuffer))) 2076 (prin1 name byte-compile--outbuffer)))
2037 (insert (car info)) 2077 (insert (car info))
2038 (let ((print-escape-newlines t) 2078 (let ((print-escape-newlines t)
2039 (print-quoted t) 2079 (print-quoted t)
@@ -2048,7 +2088,7 @@ list that represents a doc string reference.
2048 (print-continuous-numbering t) 2088 (print-continuous-numbering t)
2049 print-number-table 2089 print-number-table
2050 (index 0)) 2090 (index 0))
2051 (prin1 (car form) bytecomp-outbuffer) 2091 (prin1 (car form) byte-compile--outbuffer)
2052 (while (setq form (cdr form)) 2092 (while (setq form (cdr form))
2053 (setq index (1+ index)) 2093 (setq index (1+ index))
2054 (insert " ") 2094 (insert " ")
@@ -2059,7 +2099,7 @@ list that represents a doc string reference.
2059 ;; (for instance, gensyms in the arg list). 2099 ;; (for instance, gensyms in the arg list).
2060 (let (non-nil) 2100 (let (non-nil)
2061 (when (hash-table-p print-number-table) 2101 (when (hash-table-p print-number-table)
2062 (maphash (lambda (k v) (if v (setq non-nil t))) 2102 (maphash (lambda (_k v) (if v (setq non-nil t)))
2063 print-number-table)) 2103 print-number-table))
2064 (not non-nil))) 2104 (not non-nil)))
2065 ;; Output the byte code and constants specially 2105 ;; Output the byte code and constants specially
@@ -2068,37 +2108,40 @@ list that represents a doc string reference.
2068 (byte-compile-output-as-comment 2108 (byte-compile-output-as-comment
2069 (cons (car form) (nth 1 form)) 2109 (cons (car form) (nth 1 form))
2070 t))) 2110 t)))
2071 (setq position (- (position-bytes position) (point-min) -1)) 2111 (setq position (- (position-bytes position)
2072 (princ (format "(#$ . %d) nil" position) bytecomp-outbuffer) 2112 (point-min) -1))
2113 (princ (format "(#$ . %d) nil" position)
2114 byte-compile--outbuffer)
2073 (setq form (cdr form)) 2115 (setq form (cdr form))
2074 (setq index (1+ index)))) 2116 (setq index (1+ index))))
2075 ((= index (nth 1 info)) 2117 ((= index (nth 1 info))
2076 (if position 2118 (if position
2077 (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") 2119 (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
2078 position) 2120 position)
2079 bytecomp-outbuffer) 2121 byte-compile--outbuffer)
2080 (let ((print-escape-newlines nil)) 2122 (let ((print-escape-newlines nil))
2081 (goto-char (prog1 (1+ (point)) 2123 (goto-char (prog1 (1+ (point))
2082 (prin1 (car form) bytecomp-outbuffer))) 2124 (prin1 (car form)
2125 byte-compile--outbuffer)))
2083 (insert "\\\n") 2126 (insert "\\\n")
2084 (goto-char (point-max))))) 2127 (goto-char (point-max)))))
2085 (t 2128 (t
2086 (prin1 (car form) bytecomp-outbuffer))))) 2129 (prin1 (car form) byte-compile--outbuffer)))))
2087 (insert (nth 2 info))))) 2130 (insert (nth 2 info)))))
2088 nil) 2131 nil)
2089 2132
2090(defun byte-compile-keep-pending (form &optional bytecomp-handler) 2133(defun byte-compile-keep-pending (form &optional handler)
2091 (if (memq byte-optimize '(t source)) 2134 (if (memq byte-optimize '(t source))
2092 (setq form (byte-optimize-form form t))) 2135 (setq form (byte-optimize-form form t)))
2093 (if bytecomp-handler 2136 (if handler
2094 (let ((for-effect t)) 2137 (let ((byte-compile--for-effect t))
2095 ;; To avoid consing up monstrously large forms at load time, we split 2138 ;; To avoid consing up monstrously large forms at load time, we split
2096 ;; the output regularly. 2139 ;; the output regularly.
2097 (and (memq (car-safe form) '(fset defalias)) 2140 (and (memq (car-safe form) '(fset defalias))
2098 (nthcdr 300 byte-compile-output) 2141 (nthcdr 300 byte-compile-output)
2099 (byte-compile-flush-pending)) 2142 (byte-compile-flush-pending))
2100 (funcall bytecomp-handler form) 2143 (funcall handler form)
2101 (if for-effect 2144 (if byte-compile--for-effect
2102 (byte-compile-discard))) 2145 (byte-compile-discard)))
2103 (byte-compile-form form t)) 2146 (byte-compile-form form t))
2104 nil) 2147 nil)
@@ -2116,37 +2159,39 @@ list that represents a doc string reference.
2116 byte-compile-maxdepth 0 2159 byte-compile-maxdepth 0
2117 byte-compile-output nil)))) 2160 byte-compile-output nil))))
2118 2161
2162(defun byte-compile-preprocess (form &optional _for-effect)
2163 (setq form (macroexpand-all form byte-compile-macro-environment))
2164 ;; FIXME: We should run byte-optimize-form here, but it currently does not
2165 ;; recurse through all the code, so we'd have to fix this first.
2166 ;; Maybe a good fix would be to merge byte-optimize-form into
2167 ;; macroexpand-all.
2168 ;; (if (memq byte-optimize '(t source))
2169 ;; (setq form (byte-optimize-form form for-effect)))
2170 (if lexical-binding
2171 (cconv-closure-convert form)
2172 form))
2173
2174;; byte-hunk-handlers cannot call this!
2175(defun byte-compile-toplevel-file-form (form)
2176 (let ((byte-compile-current-form nil)) ; close over this for warnings.
2177 (byte-compile-file-form (byte-compile-preprocess form t))))
2178
2179;; byte-hunk-handlers can call this.
2119(defun byte-compile-file-form (form) 2180(defun byte-compile-file-form (form)
2120 (let ((byte-compile-current-form nil) ; close over this for warnings. 2181 (let (handler)
2121 bytecomp-handler) 2182 (cond ((and (consp form)
2122 (cond 2183 (symbolp (car form))
2123 ((not (consp form)) 2184 (setq handler (get (car form) 'byte-hunk-handler)))
2124 (byte-compile-keep-pending form)) 2185 (cond ((setq form (funcall handler form))
2125 ((and (symbolp (car form)) 2186 (byte-compile-flush-pending)
2126 (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) 2187 (byte-compile-output-file-form form))))
2127 (cond ((setq form (funcall bytecomp-handler form)) 2188 (t
2128 (byte-compile-flush-pending) 2189 (byte-compile-keep-pending form)))))
2129 (byte-compile-output-file-form form))))
2130 ((eq form (setq form (macroexpand form byte-compile-macro-environment)))
2131 (byte-compile-keep-pending form))
2132 (t
2133 (byte-compile-file-form form)))))
2134 2190
2135;; Functions and variables with doc strings must be output separately, 2191;; Functions and variables with doc strings must be output separately,
2136;; so make-docfile can recognise them. Most other things can be output 2192;; so make-docfile can recognise them. Most other things can be output
2137;; as byte-code. 2193;; as byte-code.
2138 2194
2139(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
2140(defun byte-compile-file-form-defsubst (form)
2141 (when (assq (nth 1 form) byte-compile-unresolved-functions)
2142 (setq byte-compile-current-form (nth 1 form))
2143 (byte-compile-warn "defsubst `%s' was used before it was defined"
2144 (nth 1 form)))
2145 (byte-compile-file-form
2146 (macroexpand form byte-compile-macro-environment))
2147 ;; Return nil so the form is not output twice.
2148 nil)
2149
2150(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) 2195(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
2151(defun byte-compile-file-form-autoload (form) 2196(defun byte-compile-file-form-autoload (form)
2152 (and (let ((form form)) 2197 (and (let ((form form))
@@ -2200,7 +2245,8 @@ list that represents a doc string reference.
2200 (byte-compile-top-level (nth 2 form) nil 'file)))) 2245 (byte-compile-top-level (nth 2 form) nil 'file))))
2201 form)) 2246 form))
2202 2247
2203(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) 2248(put 'define-abbrev-table 'byte-hunk-handler
2249 'byte-compile-file-form-define-abbrev-table)
2204(defun byte-compile-file-form-define-abbrev-table (form) 2250(defun byte-compile-file-form-define-abbrev-table (form)
2205 (if (eq 'quote (car-safe (car-safe (cdr form)))) 2251 (if (eq 'quote (car-safe (car-safe (cdr form))))
2206 (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) 2252 (push (car-safe (cdr (cadr form))) byte-compile-bound-variables))
@@ -2298,51 +2344,49 @@ by side-effects."
2298 res)) 2344 res))
2299 2345
2300(defun byte-compile-file-form-defmumble (form macrop) 2346(defun byte-compile-file-form-defmumble (form macrop)
2301 (let* ((bytecomp-name (car (cdr form))) 2347 (let* ((name (car (cdr form)))
2302 (bytecomp-this-kind (if macrop 'byte-compile-macro-environment 2348 (this-kind (if macrop 'byte-compile-macro-environment
2303 'byte-compile-function-environment)) 2349 'byte-compile-function-environment))
2304 (bytecomp-that-kind (if macrop 'byte-compile-function-environment 2350 (that-kind (if macrop 'byte-compile-function-environment
2305 'byte-compile-macro-environment)) 2351 'byte-compile-macro-environment))
2306 (bytecomp-this-one (assq bytecomp-name 2352 (this-one (assq name (symbol-value this-kind)))
2307 (symbol-value bytecomp-this-kind))) 2353 (that-one (assq name (symbol-value that-kind)))
2308 (bytecomp-that-one (assq bytecomp-name
2309 (symbol-value bytecomp-that-kind)))
2310 (byte-compile-free-references nil) 2354 (byte-compile-free-references nil)
2311 (byte-compile-free-assignments nil)) 2355 (byte-compile-free-assignments nil))
2312 (byte-compile-set-symbol-position bytecomp-name) 2356 (byte-compile-set-symbol-position name)
2313 ;; When a function or macro is defined, add it to the call tree so that 2357 ;; When a function or macro is defined, add it to the call tree so that
2314 ;; we can tell when functions are not used. 2358 ;; we can tell when functions are not used.
2315 (if byte-compile-generate-call-tree 2359 (if byte-compile-generate-call-tree
2316 (or (assq bytecomp-name byte-compile-call-tree) 2360 (or (assq name byte-compile-call-tree)
2317 (setq byte-compile-call-tree 2361 (setq byte-compile-call-tree
2318 (cons (list bytecomp-name nil nil) byte-compile-call-tree)))) 2362 (cons (list name nil nil) byte-compile-call-tree))))
2319 2363
2320 (setq byte-compile-current-form bytecomp-name) ; for warnings 2364 (setq byte-compile-current-form name) ; for warnings
2321 (if (byte-compile-warning-enabled-p 'redefine) 2365 (if (byte-compile-warning-enabled-p 'redefine)
2322 (byte-compile-arglist-warn form macrop)) 2366 (byte-compile-arglist-warn form macrop))
2323 (if byte-compile-verbose 2367 (if byte-compile-verbose
2324 ;; bytecomp-filename is from byte-compile-from-buffer. 2368 (message "Compiling %s... (%s)"
2325 (message "Compiling %s... (%s)" (or bytecomp-filename "") (nth 1 form))) 2369 (or byte-compile-current-file "") (nth 1 form)))
2326 (cond (bytecomp-that-one 2370 (cond (that-one
2327 (if (and (byte-compile-warning-enabled-p 'redefine) 2371 (if (and (byte-compile-warning-enabled-p 'redefine)
2328 ;; don't warn when compiling the stubs in byte-run... 2372 ;; don't warn when compiling the stubs in byte-run...
2329 (not (assq (nth 1 form) 2373 (not (assq (nth 1 form)
2330 byte-compile-initial-macro-environment))) 2374 byte-compile-initial-macro-environment)))
2331 (byte-compile-warn 2375 (byte-compile-warn
2332 "`%s' defined multiple times, as both function and macro" 2376 "`%s' defined multiple times, as both function and macro"
2333 (nth 1 form))) 2377 (nth 1 form)))
2334 (setcdr bytecomp-that-one nil)) 2378 (setcdr that-one nil))
2335 (bytecomp-this-one 2379 (this-one
2336 (when (and (byte-compile-warning-enabled-p 'redefine) 2380 (when (and (byte-compile-warning-enabled-p 'redefine)
2337 ;; hack: don't warn when compiling the magic internal 2381 ;; hack: don't warn when compiling the magic internal
2338 ;; byte-compiler macros in byte-run.el... 2382 ;; byte-compiler macros in byte-run.el...
2339 (not (assq (nth 1 form) 2383 (not (assq (nth 1 form)
2340 byte-compile-initial-macro-environment))) 2384 byte-compile-initial-macro-environment)))
2341 (byte-compile-warn "%s `%s' defined multiple times in this file" 2385 (byte-compile-warn "%s `%s' defined multiple times in this file"
2342 (if macrop "macro" "function") 2386 (if macrop "macro" "function")
2343 (nth 1 form)))) 2387 (nth 1 form))))
2344 ((and (fboundp bytecomp-name) 2388 ((and (fboundp name)
2345 (eq (car-safe (symbol-function bytecomp-name)) 2389 (eq (car-safe (symbol-function name))
2346 (if macrop 'lambda 'macro))) 2390 (if macrop 'lambda 'macro)))
2347 (when (byte-compile-warning-enabled-p 'redefine) 2391 (when (byte-compile-warning-enabled-p 'redefine)
2348 (byte-compile-warn "%s `%s' being redefined as a %s" 2392 (byte-compile-warn "%s `%s' being redefined as a %s"
@@ -2350,9 +2394,9 @@ by side-effects."
2350 (nth 1 form) 2394 (nth 1 form)
2351 (if macrop "macro" "function"))) 2395 (if macrop "macro" "function")))
2352 ;; shadow existing definition 2396 ;; shadow existing definition
2353 (set bytecomp-this-kind 2397 (set this-kind
2354 (cons (cons bytecomp-name nil) 2398 (cons (cons name nil)
2355 (symbol-value bytecomp-this-kind)))) 2399 (symbol-value this-kind))))
2356 ) 2400 )
2357 (let ((body (nthcdr 3 form))) 2401 (let ((body (nthcdr 3 form)))
2358 (when (and (stringp (car body)) 2402 (when (and (stringp (car body))
@@ -2367,67 +2411,51 @@ by side-effects."
2367 ;; Remove declarations from the body of the macro definition. 2411 ;; Remove declarations from the body of the macro definition.
2368 (when macrop 2412 (when macrop
2369 (dolist (decl (byte-compile-defmacro-declaration form)) 2413 (dolist (decl (byte-compile-defmacro-declaration form))
2370 (prin1 decl bytecomp-outbuffer))) 2414 (prin1 decl byte-compile--outbuffer)))
2371 2415
2372 (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t)) 2416 (let* ((code (byte-compile-lambda (nthcdr 2 form) t)))
2373 (code (byte-compile-byte-code-maker new-one))) 2417 (if this-one
2374 (if bytecomp-this-one 2418 (setcdr this-one code)
2375 (setcdr bytecomp-this-one new-one) 2419 (set this-kind
2376 (set bytecomp-this-kind 2420 (cons (cons name code)
2377 (cons (cons bytecomp-name new-one) 2421 (symbol-value this-kind))))
2378 (symbol-value bytecomp-this-kind)))) 2422 (byte-compile-flush-pending)
2379 (if (and (stringp (nth 3 form)) 2423 (if (not (stringp (nth 3 form)))
2380 (eq 'quote (car-safe code)) 2424 ;; No doc string. Provide -1 as the "doc string index"
2381 (eq 'lambda (car-safe (nth 1 code)))) 2425 ;; so that no element will be treated as a doc string.
2382 (cons (car form) 2426 (byte-compile-output-docform
2383 (cons bytecomp-name (cdr (nth 1 code)))) 2427 "\n(defalias '"
2384 (byte-compile-flush-pending) 2428 name
2385 (if (not (stringp (nth 3 form))) 2429 (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))
2386 ;; No doc string. Provide -1 as the "doc string index" 2430 (append code nil) ; Turn byte-code-function-p into list.
2387 ;; so that no element will be treated as a doc string. 2431 (and (atom code) byte-compile-dynamic
2388 (byte-compile-output-docform 2432 1)
2389 "\n(defalias '" 2433 nil)
2390 bytecomp-name 2434 ;; Output the form by hand, that's much simpler than having
2391 (cond ((atom code) 2435 ;; b-c-output-file-form analyze the defalias.
2392 (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) 2436 (byte-compile-output-docform
2393 ((eq (car code) 'quote) 2437 "\n(defalias '"
2394 (setq code new-one) 2438 name
2395 (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) 2439 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))
2396 ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) 2440 (append code nil) ; Turn byte-code-function-p into list.
2397 (append code nil) 2441 (and (atom code) byte-compile-dynamic
2398 (and (atom code) byte-compile-dynamic 2442 1)
2399 1) 2443 nil))
2400 nil) 2444 (princ ")" byte-compile--outbuffer)
2401 ;; Output the form by hand, that's much simpler than having 2445 nil)))
2402 ;; b-c-output-file-form analyze the defalias.
2403 (byte-compile-output-docform
2404 "\n(defalias '"
2405 bytecomp-name
2406 (cond ((atom code)
2407 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
2408 ((eq (car code) 'quote)
2409 (setq code new-one)
2410 (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")")))
2411 ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")"))))
2412 (append code nil)
2413 (and (atom code) byte-compile-dynamic
2414 1)
2415 nil))
2416 (princ ")" bytecomp-outbuffer)
2417 nil))))
2418 2446
2419;; Print Lisp object EXP in the output file, inside a comment, 2447;; Print Lisp object EXP in the output file, inside a comment,
2420;; and return the file position it will have. 2448;; and return the file position it will have.
2421;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. 2449;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
2422(defun byte-compile-output-as-comment (exp quoted) 2450(defun byte-compile-output-as-comment (exp quoted)
2423 (let ((position (point))) 2451 (let ((position (point)))
2424 (with-current-buffer bytecomp-outbuffer 2452 (with-current-buffer byte-compile--outbuffer
2425 2453
2426 ;; Insert EXP, and make it a comment with #@LENGTH. 2454 ;; Insert EXP, and make it a comment with #@LENGTH.
2427 (insert " ") 2455 (insert " ")
2428 (if quoted 2456 (if quoted
2429 (prin1 exp bytecomp-outbuffer) 2457 (prin1 exp byte-compile--outbuffer)
2430 (princ exp bytecomp-outbuffer)) 2458 (princ exp byte-compile--outbuffer))
2431 (goto-char position) 2459 (goto-char position)
2432 ;; Quote certain special characters as needed. 2460 ;; Quote certain special characters as needed.
2433 ;; get_doc_string in doc.c does the unquoting. 2461 ;; get_doc_string in doc.c does the unquoting.
@@ -2469,6 +2497,10 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2469 (if macro 2497 (if macro
2470 (setq fun (cdr fun))) 2498 (setq fun (cdr fun)))
2471 (cond ((eq (car-safe fun) 'lambda) 2499 (cond ((eq (car-safe fun) 'lambda)
2500 ;; Expand macros.
2501 (setq fun (byte-compile-preprocess fun))
2502 ;; Get rid of the `function' quote added by the `lambda' macro.
2503 (if (eq (car-safe fun) 'function) (setq fun (cadr fun)))
2472 (setq fun (if macro 2504 (setq fun (if macro
2473 (cons 'macro (byte-compile-lambda fun)) 2505 (cons 'macro (byte-compile-lambda fun))
2474 (byte-compile-lambda fun))) 2506 (byte-compile-lambda fun)))
@@ -2480,56 +2512,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2480 "Compile and return SEXP." 2512 "Compile and return SEXP."
2481 (displaying-byte-compile-warnings 2513 (displaying-byte-compile-warnings
2482 (byte-compile-close-variables 2514 (byte-compile-close-variables
2483 (byte-compile-top-level sexp)))) 2515 (byte-compile-top-level (byte-compile-preprocess sexp)))))
2484
2485;; Given a function made by byte-compile-lambda, make a form which produces it.
2486(defun byte-compile-byte-code-maker (fun)
2487 (cond
2488 ;; ## atom is faster than compiled-func-p.
2489 ((atom fun) ; compiled function.
2490 ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
2491 ;; would have produced a lambda.
2492 fun)
2493 ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial
2494 ;; function, or this is Emacs 18, or generate-emacs19-bytecodes is off.
2495 ((let (tmp)
2496 (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
2497 (null (cdr (memq tmp fun))))
2498 ;; Generate a make-byte-code call.
2499 (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
2500 (nconc (list 'make-byte-code
2501 (list 'quote (nth 1 fun)) ;arglist
2502 (nth 1 tmp) ;bytes
2503 (nth 2 tmp) ;consts
2504 (nth 3 tmp)) ;depth
2505 (cond ((stringp (nth 2 fun))
2506 (list (nth 2 fun))) ;doc
2507 (interactive
2508 (list nil)))
2509 (cond (interactive
2510 (list (if (or (null (nth 1 interactive))
2511 (stringp (nth 1 interactive)))
2512 (nth 1 interactive)
2513 ;; Interactive spec is a list or a variable
2514 ;; (if it is correct).
2515 (list 'quote (nth 1 interactive))))))))
2516 ;; a non-compiled function (probably trivial)
2517 (list 'quote fun))))))
2518
2519;; Turn a function into an ordinary lambda. Needed for v18 files.
2520(defun byte-compile-byte-code-unmake (function)
2521 (if (consp function)
2522 function;;It already is a lambda.
2523 (setq function (append function nil)) ; turn it into a list
2524 (nconc (list 'lambda (nth 0 function))
2525 (and (nth 4 function) (list (nth 4 function)))
2526 (if (nthcdr 5 function)
2527 (list (cons 'interactive (if (nth 5 function)
2528 (nthcdr 5 function)))))
2529 (list (list 'byte-code
2530 (nth 1 function) (nth 2 function)
2531 (nth 3 function))))))
2532
2533 2516
2534(defun byte-compile-check-lambda-list (list) 2517(defun byte-compile-check-lambda-list (list)
2535 "Check lambda-list LIST for errors." 2518 "Check lambda-list LIST for errors."
@@ -2556,6 +2539,44 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2556 (setq list (cdr list))))) 2539 (setq list (cdr list)))))
2557 2540
2558 2541
2542(defun byte-compile-arglist-vars (arglist)
2543 "Return a list of the variables in the lambda argument list ARGLIST."
2544 (remq '&rest (remq '&optional arglist)))
2545
2546(defun byte-compile-make-lambda-lexenv (form)
2547 "Return a new lexical environment for a lambda expression FORM."
2548 ;; See if this is a closure or not
2549 (let ((args (byte-compile-arglist-vars (cadr form))))
2550 (let ((lexenv nil))
2551 ;; Fill in the initial stack contents
2552 (let ((stackpos 0))
2553 ;; Add entries for each argument
2554 (dolist (arg args)
2555 (push (cons arg stackpos) lexenv)
2556 (setq stackpos (1+ stackpos)))
2557 ;; Return the new lexical environment
2558 lexenv))))
2559
2560(defun byte-compile-make-args-desc (arglist)
2561 (let ((mandatory 0)
2562 nonrest (rest 0))
2563 (while (and arglist (not (memq (car arglist) '(&optional &rest))))
2564 (setq mandatory (1+ mandatory))
2565 (setq arglist (cdr arglist)))
2566 (setq nonrest mandatory)
2567 (when (eq (car arglist) '&optional)
2568 (setq arglist (cdr arglist))
2569 (while (and arglist (not (eq (car arglist) '&rest)))
2570 (setq nonrest (1+ nonrest))
2571 (setq arglist (cdr arglist))))
2572 (when arglist
2573 (setq rest 1))
2574 (if (> mandatory 127)
2575 (byte-compile-report-error "Too many (>127) mandatory arguments")
2576 (logior mandatory
2577 (lsh nonrest 8)
2578 (lsh rest 7)))))
2579
2559;; Byte-compile a lambda-expression and return a valid function. 2580;; Byte-compile a lambda-expression and return a valid function.
2560;; The value is usually a compiled function but may be the original 2581;; The value is usually a compiled function but may be the original
2561;; lambda-expression. 2582;; lambda-expression.
@@ -2563,78 +2584,87 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2563;; of the list FUN and `byte-compile-set-symbol-position' is not called. 2584;; of the list FUN and `byte-compile-set-symbol-position' is not called.
2564;; Use this feature to avoid calling `byte-compile-set-symbol-position' 2585;; Use this feature to avoid calling `byte-compile-set-symbol-position'
2565;; for symbols generated by the byte compiler itself. 2586;; for symbols generated by the byte compiler itself.
2566(defun byte-compile-lambda (bytecomp-fun &optional add-lambda) 2587(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
2567 (if add-lambda 2588 (if add-lambda
2568 (setq bytecomp-fun (cons 'lambda bytecomp-fun)) 2589 (setq fun (cons 'lambda fun))
2569 (unless (eq 'lambda (car-safe bytecomp-fun)) 2590 (unless (eq 'lambda (car-safe fun))
2570 (error "Not a lambda list: %S" bytecomp-fun)) 2591 (error "Not a lambda list: %S" fun))
2571 (byte-compile-set-symbol-position 'lambda)) 2592 (byte-compile-set-symbol-position 'lambda))
2572 (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) 2593 (byte-compile-check-lambda-list (nth 1 fun))
2573 (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) 2594 (let* ((arglist (nth 1 fun))
2574 (byte-compile-bound-variables 2595 (byte-compile-bound-variables
2575 (nconc (and (byte-compile-warning-enabled-p 'free-vars) 2596 (append (and (not lexical-binding)
2576 (delq '&rest 2597 (byte-compile-arglist-vars arglist))
2577 (delq '&optional (copy-sequence bytecomp-arglist)))) 2598 byte-compile-bound-variables))
2578 byte-compile-bound-variables)) 2599 (body (cdr (cdr fun)))
2579 (bytecomp-body (cdr (cdr bytecomp-fun))) 2600 (doc (if (stringp (car body))
2580 (bytecomp-doc (if (stringp (car bytecomp-body)) 2601 (prog1 (car body)
2581 (prog1 (car bytecomp-body) 2602 ;; Discard the doc string
2582 ;; Discard the doc string 2603 ;; unless it is the last element of the body.
2583 ;; unless it is the last element of the body. 2604 (if (cdr body)
2584 (if (cdr bytecomp-body) 2605 (setq body (cdr body))))))
2585 (setq bytecomp-body (cdr bytecomp-body)))))) 2606 (int (assq 'interactive body)))
2586 (bytecomp-int (assq 'interactive bytecomp-body)))
2587 ;; Process the interactive spec. 2607 ;; Process the interactive spec.
2588 (when bytecomp-int 2608 (when int
2589 (byte-compile-set-symbol-position 'interactive) 2609 (byte-compile-set-symbol-position 'interactive)
2590 ;; Skip (interactive) if it is in front (the most usual location). 2610 ;; Skip (interactive) if it is in front (the most usual location).
2591 (if (eq bytecomp-int (car bytecomp-body)) 2611 (if (eq int (car body))
2592 (setq bytecomp-body (cdr bytecomp-body))) 2612 (setq body (cdr body)))
2593 (cond ((consp (cdr bytecomp-int)) 2613 (cond ((consp (cdr int))
2594 (if (cdr (cdr bytecomp-int)) 2614 (if (cdr (cdr int))
2595 (byte-compile-warn "malformed interactive spec: %s" 2615 (byte-compile-warn "malformed interactive spec: %s"
2596 (prin1-to-string bytecomp-int))) 2616 (prin1-to-string int)))
2597 ;; If the interactive spec is a call to `list', don't 2617 ;; If the interactive spec is a call to `list', don't
2598 ;; compile it, because `call-interactively' looks at the 2618 ;; compile it, because `call-interactively' looks at the
2599 ;; args of `list'. Actually, compile it to get warnings, 2619 ;; args of `list'. Actually, compile it to get warnings,
2600 ;; but don't use the result. 2620 ;; but don't use the result.
2601 (let ((form (nth 1 bytecomp-int))) 2621 (let* ((form (nth 1 int))
2622 (newform (byte-compile-top-level form)))
2602 (while (memq (car-safe form) '(let let* progn save-excursion)) 2623 (while (memq (car-safe form) '(let let* progn save-excursion))
2603 (while (consp (cdr form)) 2624 (while (consp (cdr form))
2604 (setq form (cdr form))) 2625 (setq form (cdr form)))
2605 (setq form (car form))) 2626 (setq form (car form)))
2606 (if (eq (car-safe form) 'list) 2627 (if (and (eq (car-safe form) 'list)
2607 (byte-compile-top-level (nth 1 bytecomp-int)) 2628 ;; The spec is evaled in callint.c in dynamic-scoping
2608 (setq bytecomp-int (list 'interactive 2629 ;; mode, so just leaving the form unchanged would mean
2609 (byte-compile-top-level 2630 ;; it won't be eval'd in the right mode.
2610 (nth 1 bytecomp-int))))))) 2631 (not lexical-binding))
2611 ((cdr bytecomp-int) 2632 nil
2633 (setq int `(interactive ,newform)))))
2634 ((cdr int)
2612 (byte-compile-warn "malformed interactive spec: %s" 2635 (byte-compile-warn "malformed interactive spec: %s"
2613 (prin1-to-string bytecomp-int))))) 2636 (prin1-to-string int)))))
2614 ;; Process the body. 2637 ;; Process the body.
2615 (let ((compiled (byte-compile-top-level 2638 (let ((compiled
2616 (cons 'progn bytecomp-body) nil 'lambda))) 2639 (byte-compile-top-level (cons 'progn body) nil 'lambda
2640 ;; If doing lexical binding, push a new
2641 ;; lexical environment containing just the
2642 ;; args (since lambda expressions should be
2643 ;; closed by now).
2644 (and lexical-binding
2645 (byte-compile-make-lambda-lexenv fun))
2646 reserved-csts)))
2617 ;; Build the actual byte-coded function. 2647 ;; Build the actual byte-coded function.
2618 (if (eq 'byte-code (car-safe compiled)) 2648 (if (eq 'byte-code (car-safe compiled))
2619 (apply 'make-byte-code 2649 (apply 'make-byte-code
2620 (append (list bytecomp-arglist) 2650 (if lexical-binding
2621 ;; byte-string, constants-vector, stack depth 2651 (byte-compile-make-args-desc arglist)
2622 (cdr compiled) 2652 arglist)
2623 ;; optionally, the doc string. 2653 (append
2624 (if (or bytecomp-doc bytecomp-int) 2654 ;; byte-string, constants-vector, stack depth
2625 (list bytecomp-doc)) 2655 (cdr compiled)
2626 ;; optionally, the interactive spec. 2656 ;; optionally, the doc string.
2627 (if bytecomp-int 2657 (cond (lexical-binding
2628 (list (nth 1 bytecomp-int))))) 2658 (require 'help-fns)
2629 (setq compiled 2659 (list (help-add-fundoc-usage doc arglist)))
2630 (nconc (if bytecomp-int (list bytecomp-int)) 2660 ((or doc int)
2631 (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) 2661 (list doc)))
2632 (compiled (list compiled))))) 2662 ;; optionally, the interactive spec.
2633 (nconc (list 'lambda bytecomp-arglist) 2663 (if int
2634 (if (or bytecomp-doc (stringp (car compiled))) 2664 (list (nth 1 int)))))
2635 (cons bytecomp-doc (cond (compiled) 2665 (error "byte-compile-top-level did not return byte-code")))))
2636 (bytecomp-body (list nil)))) 2666
2637 compiled)))))) 2667(defvar byte-compile-reserved-constants 0)
2638 2668
2639(defun byte-compile-constants-vector () 2669(defun byte-compile-constants-vector ()
2640 ;; Builds the constants-vector from the current variables and constants. 2670 ;; Builds the constants-vector from the current variables and constants.
@@ -2644,7 +2674,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2644 ;; Next up to byte-constant-limit are constants, still with one-byte codes. 2674 ;; Next up to byte-constant-limit are constants, still with one-byte codes.
2645 ;; Next variables again, to get 2-byte codes for variable lookup. 2675 ;; Next variables again, to get 2-byte codes for variable lookup.
2646 ;; The rest of the constants and variables need 3-byte byte-codes. 2676 ;; The rest of the constants and variables need 3-byte byte-codes.
2647 (let* ((i -1) 2677 (let* ((i (1- byte-compile-reserved-constants))
2648 (rest (nreverse byte-compile-variables)) ; nreverse because the first 2678 (rest (nreverse byte-compile-variables)) ; nreverse because the first
2649 (other (nreverse byte-compile-constants)) ; vars often are used most. 2679 (other (nreverse byte-compile-constants)) ; vars often are used most.
2650 ret tmp 2680 ret tmp
@@ -2655,11 +2685,15 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2655 limit) 2685 limit)
2656 (while (or rest other) 2686 (while (or rest other)
2657 (setq limit (car limits)) 2687 (setq limit (car limits))
2658 (while (and rest (not (eq i limit))) 2688 (while (and rest (< i limit))
2659 (if (setq tmp (assq (car (car rest)) ret)) 2689 (cond
2660 (setcdr (car rest) (cdr tmp)) 2690 ((numberp (car rest))
2691 (assert (< (car rest) byte-compile-reserved-constants)))
2692 ((setq tmp (assq (car (car rest)) ret))
2693 (setcdr (car rest) (cdr tmp)))
2694 (t
2661 (setcdr (car rest) (setq i (1+ i))) 2695 (setcdr (car rest) (setq i (1+ i)))
2662 (setq ret (cons (car rest) ret))) 2696 (setq ret (cons (car rest) ret))))
2663 (setq rest (cdr rest))) 2697 (setq rest (cdr rest)))
2664 (setq limits (cdr limits) 2698 (setq limits (cdr limits)
2665 rest (prog1 other 2699 rest (prog1 other
@@ -2668,29 +2702,38 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2668 2702
2669;; Given an expression FORM, compile it and return an equivalent byte-code 2703;; Given an expression FORM, compile it and return an equivalent byte-code
2670;; expression (a call to the function byte-code). 2704;; expression (a call to the function byte-code).
2671(defun byte-compile-top-level (form &optional for-effect output-type) 2705(defun byte-compile-top-level (form &optional for-effect output-type
2706 lexenv reserved-csts)
2672 ;; OUTPUT-TYPE advises about how form is expected to be used: 2707 ;; OUTPUT-TYPE advises about how form is expected to be used:
2673 ;; 'eval or nil -> a single form, 2708 ;; 'eval or nil -> a single form,
2674 ;; 'progn or t -> a list of forms, 2709 ;; 'progn or t -> a list of forms,
2675 ;; 'lambda -> body of a lambda, 2710 ;; 'lambda -> body of a lambda,
2676 ;; 'file -> used at file-level. 2711 ;; 'file -> used at file-level.
2677 (let ((byte-compile-constants nil) 2712 (let ((byte-compile--for-effect for-effect)
2713 (byte-compile-constants nil)
2678 (byte-compile-variables nil) 2714 (byte-compile-variables nil)
2679 (byte-compile-tag-number 0) 2715 (byte-compile-tag-number 0)
2680 (byte-compile-depth 0) 2716 (byte-compile-depth 0)
2681 (byte-compile-maxdepth 0) 2717 (byte-compile-maxdepth 0)
2718 (byte-compile--lexical-environment lexenv)
2719 (byte-compile-reserved-constants (or reserved-csts 0))
2682 (byte-compile-output nil)) 2720 (byte-compile-output nil))
2683 (if (memq byte-optimize '(t source)) 2721 (if (memq byte-optimize '(t source))
2684 (setq form (byte-optimize-form form for-effect))) 2722 (setq form (byte-optimize-form form byte-compile--for-effect)))
2685 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) 2723 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
2686 (setq form (nth 1 form))) 2724 (setq form (nth 1 form)))
2687 (if (and (eq 'byte-code (car-safe form)) 2725 ;; Set up things for a lexically-bound function.
2688 (not (memq byte-optimize '(t byte))) 2726 (when (and lexical-binding (eq output-type 'lambda))
2689 (stringp (nth 1 form)) (vectorp (nth 2 form)) 2727 ;; See how many arguments there are, and set the current stack depth
2690 (natnump (nth 3 form))) 2728 ;; accordingly.
2691 form 2729 (setq byte-compile-depth (length byte-compile--lexical-environment))
2692 (byte-compile-form form for-effect) 2730 ;; If there are args, output a tag to record the initial
2693 (byte-compile-out-toplevel for-effect output-type)))) 2731 ;; stack-depth for the optimizer.
2732 (when (> byte-compile-depth 0)
2733 (byte-compile-out-tag (byte-compile-make-tag))))
2734 ;; Now compile FORM
2735 (byte-compile-form form byte-compile--for-effect)
2736 (byte-compile-out-toplevel byte-compile--for-effect output-type)))
2694 2737
2695(defun byte-compile-out-toplevel (&optional for-effect output-type) 2738(defun byte-compile-out-toplevel (&optional for-effect output-type)
2696 (if for-effect 2739 (if for-effect
@@ -2712,7 +2755,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2712 (setq byte-compile-output (nreverse byte-compile-output)) 2755 (setq byte-compile-output (nreverse byte-compile-output))
2713 (if (memq byte-optimize '(t byte)) 2756 (if (memq byte-optimize '(t byte))
2714 (setq byte-compile-output 2757 (setq byte-compile-output
2715 (byte-optimize-lapcode byte-compile-output for-effect))) 2758 (byte-optimize-lapcode byte-compile-output)))
2716 2759
2717 ;; Decompile trivial functions: 2760 ;; Decompile trivial functions:
2718 ;; only constants and variables, or a single funcall except in lambdas. 2761 ;; only constants and variables, or a single funcall except in lambdas.
@@ -2740,34 +2783,35 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2740 (progn 2783 (progn
2741 (setq rest (nreverse 2784 (setq rest (nreverse
2742 (cdr (memq tmp (reverse byte-compile-output))))) 2785 (cdr (memq tmp (reverse byte-compile-output)))))
2743 (while (cond 2786 (while
2744 ((memq (car (car rest)) '(byte-varref byte-constant)) 2787 (cond
2745 (setq tmp (car (cdr (car rest)))) 2788 ((memq (car (car rest)) '(byte-varref byte-constant))
2746 (if (if (eq (car (car rest)) 'byte-constant) 2789 (setq tmp (car (cdr (car rest))))
2747 (or (consp tmp) 2790 (if (if (eq (car (car rest)) 'byte-constant)
2748 (and (symbolp tmp) 2791 (or (consp tmp)
2749 (not (byte-compile-const-symbol-p tmp))))) 2792 (and (symbolp tmp)
2750 (if maycall 2793 (not (byte-compile-const-symbol-p tmp)))))
2751 (setq body (cons (list 'quote tmp) body))) 2794 (if maycall
2752 (setq body (cons tmp body)))) 2795 (setq body (cons (list 'quote tmp) body)))
2753 ((and maycall 2796 (setq body (cons tmp body))))
2754 ;; Allow a funcall if at most one atom follows it. 2797 ((and maycall
2755 (null (nthcdr 3 rest)) 2798 ;; Allow a funcall if at most one atom follows it.
2756 (setq tmp (get (car (car rest)) 'byte-opcode-invert)) 2799 (null (nthcdr 3 rest))
2757 (or (null (cdr rest)) 2800 (setq tmp (get (car (car rest)) 'byte-opcode-invert))
2758 (and (memq output-type '(file progn t)) 2801 (or (null (cdr rest))
2759 (cdr (cdr rest)) 2802 (and (memq output-type '(file progn t))
2760 (eq (car (nth 1 rest)) 'byte-discard) 2803 (cdr (cdr rest))
2761 (progn (setq rest (cdr rest)) t)))) 2804 (eq (car (nth 1 rest)) 'byte-discard)
2762 (setq maycall nil) ; Only allow one real function call. 2805 (progn (setq rest (cdr rest)) t))))
2763 (setq body (nreverse body)) 2806 (setq maycall nil) ; Only allow one real function call.
2764 (setq body (list 2807 (setq body (nreverse body))
2765 (if (and (eq tmp 'funcall) 2808 (setq body (list
2766 (eq (car-safe (car body)) 'quote)) 2809 (if (and (eq tmp 'funcall)
2767 (cons (nth 1 (car body)) (cdr body)) 2810 (eq (car-safe (car body)) 'quote))
2768 (cons tmp body)))) 2811 (cons (nth 1 (car body)) (cdr body))
2769 (or (eq output-type 'file) 2812 (cons tmp body))))
2770 (not (delq nil (mapcar 'consp (cdr (car body)))))))) 2813 (or (eq output-type 'file)
2814 (not (delq nil (mapcar 'consp (cdr (car body))))))))
2771 (setq rest (cdr rest))) 2815 (setq rest (cdr rest)))
2772 rest)) 2816 rest))
2773 (let ((byte-compile-vector (byte-compile-constants-vector))) 2817 (let ((byte-compile-vector (byte-compile-constants-vector)))
@@ -2777,94 +2821,108 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2777 ((cdr body) (cons 'progn (nreverse body))) 2821 ((cdr body) (cons 'progn (nreverse body)))
2778 ((car body))))) 2822 ((car body)))))
2779 2823
2780;; Given BYTECOMP-BODY, compile it and return a new body. 2824;; Given BODY, compile it and return a new body.
2781(defun byte-compile-top-level-body (bytecomp-body &optional for-effect) 2825(defun byte-compile-top-level-body (body &optional for-effect)
2782 (setq bytecomp-body 2826 (setq body
2783 (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) 2827 (byte-compile-top-level (cons 'progn body) for-effect t))
2784 (cond ((eq (car-safe bytecomp-body) 'progn) 2828 (cond ((eq (car-safe body) 'progn)
2785 (cdr bytecomp-body)) 2829 (cdr body))
2786 (bytecomp-body 2830 (body
2787 (list bytecomp-body)))) 2831 (list body))))
2788 2832
2789(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) 2833;; Special macro-expander used during byte-compilation.
2790(defun byte-compile-declare-function (form) 2834(defun byte-compile-macroexpand-declare-function (fn file &rest args)
2791 (push (cons (nth 1 form) 2835 (push (cons fn
2792 (if (and (> (length form) 3) 2836 (if (and (consp args) (listp (car args)))
2793 (listp (nth 3 form))) 2837 (list 'declared (car args))
2794 (list 'declared (nth 3 form))
2795 t)) ; arglist not specified 2838 t)) ; arglist not specified
2796 byte-compile-function-environment) 2839 byte-compile-function-environment)
2797 ;; We are stating that it _will_ be defined at runtime. 2840 ;; We are stating that it _will_ be defined at runtime.
2798 (setq byte-compile-noruntime-functions 2841 (setq byte-compile-noruntime-functions
2799 (delq (nth 1 form) byte-compile-noruntime-functions)) 2842 (delq fn byte-compile-noruntime-functions))
2800 nil) 2843 ;; Delegate the rest to the normal macro definition.
2844 (macroexpand `(declare-function ,fn ,file ,@args)))
2801 2845
2802 2846
2803;; This is the recursive entry point for compiling each subform of an 2847;; This is the recursive entry point for compiling each subform of an
2804;; expression. 2848;; expression.
2805;; If for-effect is non-nil, byte-compile-form will output a byte-discard 2849;; If for-effect is non-nil, byte-compile-form will output a byte-discard
2806;; before terminating (ie no value will be left on the stack). 2850;; before terminating (ie no value will be left on the stack).
2807;; A byte-compile handler may, when for-effect is non-nil, choose output code 2851;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose
2808;; which does not leave a value on the stack, and then set for-effect to nil 2852;; output code which does not leave a value on the stack, and then set
2809;; (to prevent byte-compile-form from outputting the byte-discard). 2853;; byte-compile--for-effect to nil (to prevent byte-compile-form from
2854;; outputting the byte-discard).
2810;; If a handler wants to call another handler, it should do so via 2855;; If a handler wants to call another handler, it should do so via
2811;; byte-compile-form, or take extreme care to handle for-effect correctly. 2856;; byte-compile-form, or take extreme care to handle byte-compile--for-effect
2812;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) 2857;; correctly. (Use byte-compile-form-do-effect to reset the
2858;; byte-compile--for-effect flag too.)
2813;; 2859;;
2814(defun byte-compile-form (form &optional for-effect) 2860(defun byte-compile-form (form &optional for-effect)
2815 (setq form (macroexpand form byte-compile-macro-environment)) 2861 (let ((byte-compile--for-effect for-effect))
2816 (cond ((not (consp form)) 2862 (cond
2817 (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) 2863 ((not (consp form))
2818 (when (symbolp form) 2864 (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
2819 (byte-compile-set-symbol-position form)) 2865 (when (symbolp form)
2820 (byte-compile-constant form)) 2866 (byte-compile-set-symbol-position form))
2821 ((and for-effect byte-compile-delete-errors) 2867 (byte-compile-constant form))
2822 (when (symbolp form) 2868 ((and byte-compile--for-effect byte-compile-delete-errors)
2823 (byte-compile-set-symbol-position form)) 2869 (when (symbolp form)
2824 (setq for-effect nil)) 2870 (byte-compile-set-symbol-position form))
2825 (t (byte-compile-variable-ref 'byte-varref form)))) 2871 (setq byte-compile--for-effect nil))
2826 ((symbolp (car form)) 2872 (t
2827 (let* ((bytecomp-fn (car form)) 2873 (byte-compile-variable-ref form))))
2828 (bytecomp-handler (get bytecomp-fn 'byte-compile))) 2874 ((symbolp (car form))
2829 (when (byte-compile-const-symbol-p bytecomp-fn) 2875 (let* ((fn (car form))
2830 (byte-compile-warn "`%s' called as a function" bytecomp-fn)) 2876 (handler (get fn 'byte-compile)))
2831 (and (byte-compile-warning-enabled-p 'interactive-only) 2877 (when (byte-compile-const-symbol-p fn)
2832 (memq bytecomp-fn byte-compile-interactive-only-functions) 2878 (byte-compile-warn "`%s' called as a function" fn))
2833 (byte-compile-warn "`%s' used from Lisp code\n\ 2879 (and (byte-compile-warning-enabled-p 'interactive-only)
2834That command is designed for interactive use only" bytecomp-fn)) 2880 (memq fn byte-compile-interactive-only-functions)
2835 (when (byte-compile-warning-enabled-p 'callargs) 2881 (byte-compile-warn "`%s' used from Lisp code\n\
2836 (if (memq bytecomp-fn 2882That command is designed for interactive use only" fn))
2837 '(custom-declare-group custom-declare-variable 2883 (if (and (fboundp (car form))
2838 custom-declare-face)) 2884 (eq (car-safe (symbol-function (car form))) 'macro))
2839 (byte-compile-nogroup-warn form)) 2885 (byte-compile-report-error
2840 (byte-compile-callargs-warn form)) 2886 (format "Forgot to expand macro %s" (car form))))
2841 (if (and bytecomp-handler 2887 (if (and handler
2842 ;; Make sure that function exists. This is important 2888 ;; Make sure that function exists. This is important
2843 ;; for CL compiler macros since the symbol may be 2889 ;; for CL compiler macros since the symbol may be
2844 ;; `cl-byte-compile-compiler-macro' but if CL isn't 2890 ;; `cl-byte-compile-compiler-macro' but if CL isn't
2845 ;; loaded, this function doesn't exist. 2891 ;; loaded, this function doesn't exist.
2846 (or (not (memq bytecomp-handler 2892 (and (not (eq handler
2847 '(cl-byte-compile-compiler-macro))) 2893 ;; Already handled by macroexpand-all.
2848 (functionp bytecomp-handler))) 2894 'cl-byte-compile-compiler-macro))
2849 (funcall bytecomp-handler form) 2895 (functionp handler)))
2850 (byte-compile-normal-call form)) 2896 (funcall handler form)
2851 (if (byte-compile-warning-enabled-p 'cl-functions) 2897 (byte-compile-normal-call form))
2852 (byte-compile-cl-warn form)))) 2898 (if (byte-compile-warning-enabled-p 'cl-functions)
2853 ((and (or (byte-code-function-p (car form)) 2899 (byte-compile-cl-warn form))))
2854 (eq (car-safe (car form)) 'lambda)) 2900 ((and (byte-code-function-p (car form))
2855 ;; if the form comes out the same way it went in, that's 2901 (memq byte-optimize '(t lap)))
2856 ;; because it was malformed, and we couldn't unfold it. 2902 (byte-compile-unfold-bcf form))
2857 (not (eq form (setq form (byte-compile-unfold-lambda form))))) 2903 ((and (eq (car-safe (car form)) 'lambda)
2858 (byte-compile-form form for-effect) 2904 ;; if the form comes out the same way it went in, that's
2859 (setq for-effect nil)) 2905 ;; because it was malformed, and we couldn't unfold it.
2860 ((byte-compile-normal-call form))) 2906 (not (eq form (setq form (byte-compile-unfold-lambda form)))))
2861 (if for-effect 2907 (byte-compile-form form byte-compile--for-effect)
2862 (byte-compile-discard))) 2908 (setq byte-compile--for-effect nil))
2909 ((byte-compile-normal-call form)))
2910 (if byte-compile--for-effect
2911 (byte-compile-discard))))
2863 2912
2864(defun byte-compile-normal-call (form) 2913(defun byte-compile-normal-call (form)
2914 (when (and (byte-compile-warning-enabled-p 'callargs)
2915 (symbolp (car form)))
2916 (if (memq (car form)
2917 '(custom-declare-group custom-declare-variable
2918 custom-declare-face))
2919 (byte-compile-nogroup-warn form))
2920 (when (get (car form) 'byte-obsolete-info)
2921 (byte-compile-warn-obsolete (car form)))
2922 (byte-compile-callargs-warn form))
2865 (if byte-compile-generate-call-tree 2923 (if byte-compile-generate-call-tree
2866 (byte-compile-annotate-call-tree form)) 2924 (byte-compile-annotate-call-tree form))
2867 (when (and for-effect (eq (car form) 'mapcar) 2925 (when (and byte-compile--for-effect (eq (car form) 'mapcar)
2868 (byte-compile-warning-enabled-p 'mapcar)) 2926 (byte-compile-warning-enabled-p 'mapcar))
2869 (byte-compile-set-symbol-position 'mapcar) 2927 (byte-compile-set-symbol-position 'mapcar)
2870 (byte-compile-warn 2928 (byte-compile-warn
@@ -2873,44 +2931,142 @@ That command is designed for interactive use only" bytecomp-fn))
2873 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. 2931 (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
2874 (byte-compile-out 'byte-call (length (cdr form)))) 2932 (byte-compile-out 'byte-call (length (cdr form))))
2875 2933
2876(defun byte-compile-variable-ref (base-op bytecomp-var) 2934
2877 (when (symbolp bytecomp-var) 2935;; Splice the given lap code into the current instruction stream.
2878 (byte-compile-set-symbol-position bytecomp-var)) 2936;; If it has any labels in it, you're responsible for making sure there
2879 (if (or (not (symbolp bytecomp-var)) 2937;; are no collisions, and that byte-compile-tag-number is reasonable
2880 (byte-compile-const-symbol-p bytecomp-var 2938;; after this is spliced in. The provided list is destroyed.
2881 (not (eq base-op 'byte-varref)))) 2939(defun byte-compile-inline-lapcode (lap end-depth)
2882 (if (byte-compile-warning-enabled-p 'constants) 2940 ;; "Replay" the operations: we used to just do
2883 (byte-compile-warn 2941 ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
2884 (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") 2942 ;; but that fails to update byte-compile-depth, so we had to assume
2885 ((eq base-op 'byte-varset) "variable assignment to %s `%s'") 2943 ;; that `lap' ends up adding exactly 1 element to the stack. This
2886 (t "variable reference to %s `%s'")) 2944 ;; happens to be true for byte-code generated by bytecomp.el without
2887 (if (symbolp bytecomp-var) "constant" "nonvariable") 2945 ;; lexical-binding, but it's not true in general, and it's not true for
2888 (prin1-to-string bytecomp-var))) 2946 ;; code output by bytecomp.el with lexical-binding.
2889 (and (get bytecomp-var 'byte-obsolete-variable) 2947 (let ((endtag (byte-compile-make-tag)))
2890 (not (memq bytecomp-var byte-compile-not-obsolete-vars)) 2948 (dolist (op lap)
2891 (byte-compile-warn-obsolete bytecomp-var)) 2949 (cond
2892 (if (eq base-op 'byte-varbind) 2950 ((eq (car op) 'TAG) (byte-compile-out-tag op))
2893 (push bytecomp-var byte-compile-bound-variables) 2951 ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
2894 (or (not (byte-compile-warning-enabled-p 'free-vars)) 2952 ((eq (car op) 'byte-return)
2895 (boundp bytecomp-var) 2953 (byte-compile-discard (- byte-compile-depth end-depth) t)
2896 (memq bytecomp-var byte-compile-bound-variables) 2954 (byte-compile-goto 'byte-goto endtag))
2897 (if (eq base-op 'byte-varset) 2955 (t (byte-compile-out (car op) (cdr op)))))
2898 (or (memq bytecomp-var byte-compile-free-assignments) 2956 (byte-compile-out-tag endtag)))
2899 (progn 2957
2900 (byte-compile-warn "assignment to free variable `%s'" 2958(defun byte-compile-unfold-bcf (form)
2901 bytecomp-var) 2959 "Inline call to byte-code-functions."
2902 (push bytecomp-var byte-compile-free-assignments))) 2960 (let* ((byte-compile-bound-variables byte-compile-bound-variables)
2903 (or (memq bytecomp-var byte-compile-free-references) 2961 (fun (car form))
2904 (progn 2962 (fargs (aref fun 0))
2905 (byte-compile-warn "reference to free variable `%s'" 2963 (start-depth byte-compile-depth)
2906 bytecomp-var) 2964 (fmax2 (if (numberp fargs) (lsh fargs -7))) ;2*max+rest.
2907 (push bytecomp-var byte-compile-free-references))))))) 2965 ;; (fmin (if (numberp fargs) (logand fargs 127)))
2908 (let ((tmp (assq bytecomp-var byte-compile-variables))) 2966 (alen (length (cdr form)))
2967 (dynbinds ()))
2968 (fetch-bytecode fun)
2969 (mapc 'byte-compile-form (cdr form))
2970 (unless fmax2
2971 ;; Old-style byte-code.
2972 (assert (listp fargs))
2973 (while fargs
2974 (case (car fargs)
2975 (&optional (setq fargs (cdr fargs)))
2976 (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
2977 (push (cadr fargs) dynbinds)
2978 (setq fargs nil))
2979 (t (push (pop fargs) dynbinds))))
2980 (unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
2981 (cond
2982 ((<= (+ alen alen) fmax2)
2983 ;; Add missing &optional (or &rest) arguments.
2984 (dotimes (i (- (/ (1+ fmax2) 2) alen))
2985 (byte-compile-push-constant nil)))
2986 ((zerop (logand fmax2 1))
2987 (byte-compile-log-warning "Too many arguments for inlined function"
2988 nil :error)
2989 (byte-compile-discard (- alen (/ fmax2 2))))
2990 (t
2991 ;; Turn &rest args into a list.
2992 (let ((n (- alen (/ (1- fmax2) 2))))
2993 (assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
2994 (if (< n 5)
2995 (byte-compile-out
2996 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))
2997 0)
2998 (byte-compile-out 'byte-listN n)))))
2999 (mapc #'byte-compile-dynamic-variable-bind dynbinds)
3000 (byte-compile-inline-lapcode
3001 (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)
3002 (1+ start-depth))
3003 ;; Unbind dynamic variables.
3004 (when dynbinds
3005 (byte-compile-out 'byte-unbind (length dynbinds)))
3006 (assert (eq byte-compile-depth (1+ start-depth))
3007 nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
3008
3009(defun byte-compile-check-variable (var &optional binding)
3010 "Do various error checks before a use of the variable VAR.
3011If BINDING is non-nil, VAR is being bound."
3012 (when (symbolp var)
3013 (byte-compile-set-symbol-position var))
3014 (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
3015 (when (byte-compile-warning-enabled-p 'constants)
3016 (byte-compile-warn (if binding
3017 "attempt to let-bind %s `%s`"
3018 "variable reference to %s `%s'")
3019 (if (symbolp var) "constant" "nonvariable")
3020 (prin1-to-string var))))
3021 ((and (get var 'byte-obsolete-variable)
3022 (not (memq var byte-compile-not-obsolete-vars)))
3023 (byte-compile-warn-obsolete var))))
3024
3025(defsubst byte-compile-dynamic-variable-op (base-op var)
3026 (let ((tmp (assq var byte-compile-variables)))
2909 (unless tmp 3027 (unless tmp
2910 (setq tmp (list bytecomp-var)) 3028 (setq tmp (list var))
2911 (push tmp byte-compile-variables)) 3029 (push tmp byte-compile-variables))
2912 (byte-compile-out base-op tmp))) 3030 (byte-compile-out base-op tmp)))
2913 3031
3032(defun byte-compile-dynamic-variable-bind (var)
3033 "Generate code to bind the lexical variable VAR to the top-of-stack value."
3034 (byte-compile-check-variable var t)
3035 (push var byte-compile-bound-variables)
3036 (byte-compile-dynamic-variable-op 'byte-varbind var))
3037
3038(defun byte-compile-variable-ref (var)
3039 "Generate code to push the value of the variable VAR on the stack."
3040 (byte-compile-check-variable var)
3041 (let ((lex-binding (assq var byte-compile--lexical-environment)))
3042 (if lex-binding
3043 ;; VAR is lexically bound
3044 (byte-compile-stack-ref (cdr lex-binding))
3045 ;; VAR is dynamically bound
3046 (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
3047 (boundp var)
3048 (memq var byte-compile-bound-variables)
3049 (memq var byte-compile-free-references))
3050 (byte-compile-warn "reference to free variable `%S'" var)
3051 (push var byte-compile-free-references))
3052 (byte-compile-dynamic-variable-op 'byte-varref var))))
3053
3054(defun byte-compile-variable-set (var)
3055 "Generate code to set the variable VAR from the top-of-stack value."
3056 (byte-compile-check-variable var)
3057 (let ((lex-binding (assq var byte-compile--lexical-environment)))
3058 (if lex-binding
3059 ;; VAR is lexically bound
3060 (byte-compile-stack-set (cdr lex-binding))
3061 ;; VAR is dynamically bound
3062 (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
3063 (boundp var)
3064 (memq var byte-compile-bound-variables)
3065 (memq var byte-compile-free-assignments))
3066 (byte-compile-warn "assignment to free variable `%s'" var)
3067 (push var byte-compile-free-assignments))
3068 (byte-compile-dynamic-variable-op 'byte-varset var))))
3069
2914(defmacro byte-compile-get-constant (const) 3070(defmacro byte-compile-get-constant (const)
2915 `(or (if (stringp ,const) 3071 `(or (if (stringp ,const)
2916 ;; In a string constant, treat properties as significant. 3072 ;; In a string constant, treat properties as significant.
@@ -2923,20 +3079,20 @@ That command is designed for interactive use only" bytecomp-fn))
2923 (car (setq byte-compile-constants 3079 (car (setq byte-compile-constants
2924 (cons (list ,const) byte-compile-constants))))) 3080 (cons (list ,const) byte-compile-constants)))))
2925 3081
2926;; Use this when the value of a form is a constant. This obeys for-effect. 3082;; Use this when the value of a form is a constant.
3083;; This obeys byte-compile--for-effect.
2927(defun byte-compile-constant (const) 3084(defun byte-compile-constant (const)
2928 (if for-effect 3085 (if byte-compile--for-effect
2929 (setq for-effect nil) 3086 (setq byte-compile--for-effect nil)
2930 (when (symbolp const) 3087 (when (symbolp const)
2931 (byte-compile-set-symbol-position const)) 3088 (byte-compile-set-symbol-position const))
2932 (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) 3089 (byte-compile-out 'byte-constant (byte-compile-get-constant const))))
2933 3090
2934;; Use this for a constant that is not the value of its containing form. 3091;; Use this for a constant that is not the value of its containing form.
2935;; This ignores for-effect. 3092;; This ignores byte-compile--for-effect.
2936(defun byte-compile-push-constant (const) 3093(defun byte-compile-push-constant (const)
2937 (let ((for-effect nil)) 3094 (let ((byte-compile--for-effect nil))
2938 (inline (byte-compile-constant const)))) 3095 (inline (byte-compile-constant const))))
2939
2940 3096
2941;; Compile those primitive ordinary functions 3097;; Compile those primitive ordinary functions
2942;; which have special byte codes just for speed. 3098;; which have special byte codes just for speed.
@@ -3007,7 +3163,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3007(byte-defop-compiler bobp 0) 3163(byte-defop-compiler bobp 0)
3008(byte-defop-compiler current-buffer 0) 3164(byte-defop-compiler current-buffer 0)
3009;;(byte-defop-compiler read-char 0) ;; obsolete 3165;;(byte-defop-compiler read-char 0) ;; obsolete
3010(byte-defop-compiler interactive-p 0) 3166;; (byte-defop-compiler interactive-p 0) ;; Obsolete.
3011(byte-defop-compiler widen 0) 3167(byte-defop-compiler widen 0)
3012(byte-defop-compiler end-of-line 0-1) 3168(byte-defop-compiler end-of-line 0-1)
3013(byte-defop-compiler forward-char 0-1) 3169(byte-defop-compiler forward-char 0-1)
@@ -3090,7 +3246,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3090 (byte-compile-warn "`%s' called with %d arg%s, but requires %s" 3246 (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
3091 (car form) (length (cdr form)) 3247 (car form) (length (cdr form))
3092 (if (= 1 (length (cdr form))) "" "s") n) 3248 (if (= 1 (length (cdr form))) "" "s") n)
3093 ;; get run-time wrong-number-of-args error. 3249 ;; Get run-time wrong-number-of-args error.
3094 (byte-compile-normal-call form)) 3250 (byte-compile-normal-call form))
3095 3251
3096(defun byte-compile-no-args (form) 3252(defun byte-compile-no-args (form)
@@ -3137,12 +3293,66 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3137 ((= len 4) (byte-compile-three-args form)) 3293 ((= len 4) (byte-compile-three-args form))
3138 (t (byte-compile-subr-wrong-args form "2-3"))))) 3294 (t (byte-compile-subr-wrong-args form "2-3")))))
3139 3295
3140(defun byte-compile-noop (form) 3296(defun byte-compile-noop (_form)
3141 (byte-compile-constant nil)) 3297 (byte-compile-constant nil))
3142 3298
3143(defun byte-compile-discard () 3299(defun byte-compile-discard (&optional num preserve-tos)
3144 (byte-compile-out 'byte-discard 0)) 3300 "Output byte codes to discard the NUM entries at the top of the stack.
3145 3301NUM defaults to 1.
3302If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were
3303popped before discarding the num values, and then pushed back again after
3304discarding."
3305 (if (and (null num) (not preserve-tos))
3306 ;; common case
3307 (byte-compile-out 'byte-discard)
3308 ;; general case
3309 (unless num
3310 (setq num 1))
3311 (when (and preserve-tos (> num 0))
3312 ;; Preserve the top-of-stack value by writing it directly to the stack
3313 ;; location which will be at the top-of-stack after popping.
3314 (byte-compile-stack-set (1- (- byte-compile-depth num)))
3315 ;; Now we actually discard one less value, since we want to keep
3316 ;; the eventual TOS
3317 (setq num (1- num)))
3318 (while (> num 0)
3319 (byte-compile-out 'byte-discard)
3320 (setq num (1- num)))))
3321
3322(defun byte-compile-stack-ref (stack-pos)
3323 "Output byte codes to push the value at stack position STACK-POS."
3324 (let ((dist (- byte-compile-depth (1+ stack-pos))))
3325 (if (zerop dist)
3326 ;; A simple optimization
3327 (byte-compile-out 'byte-dup)
3328 ;; normal case
3329 (byte-compile-out 'byte-stack-ref dist))))
3330
3331(defun byte-compile-stack-set (stack-pos)
3332 "Output byte codes to store the TOS value at stack position STACK-POS."
3333 (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos))))
3334
3335(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure)
3336(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
3337
3338(defun byte-compile-make-closure (form)
3339 "Byte-compile the special `internal-make-closure' form."
3340 (if byte-compile--for-effect (setq byte-compile--for-effect nil)
3341 (let* ((vars (nth 1 form))
3342 (env (nth 2 form))
3343 (body (nthcdr 3 form))
3344 (fun
3345 (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
3346 (assert (byte-code-function-p fun))
3347 (byte-compile-form `(make-byte-code
3348 ',(aref fun 0) ',(aref fun 1)
3349 (vconcat (vector . ,env) ',(aref fun 2))
3350 ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun)))))))
3351
3352(defun byte-compile-get-closed-var (form)
3353 "Byte-compile the special `internal-get-closed-var' form."
3354 (if byte-compile--for-effect (setq byte-compile--for-effect nil)
3355 (byte-compile-out 'byte-constant (nth 1 form))))
3146 3356
3147;; Compile a function that accepts one or more args and is right-associative. 3357;; Compile a function that accepts one or more args and is right-associative.
3148;; We do it by left-associativity so that the operations 3358;; We do it by left-associativity so that the operations
@@ -3297,43 +3507,17 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3297 (byte-compile-warn 3507 (byte-compile-warn
3298 "A quoted lambda form is the second argument of `fset'. This is probably 3508 "A quoted lambda form is the second argument of `fset'. This is probably
3299 not what you want, as that lambda cannot be compiled. Consider using 3509 not what you want, as that lambda cannot be compiled. Consider using
3300 the syntax (function (lambda (...) ...)) instead."))))) 3510 the syntax #'(lambda (...) ...) instead.")))))
3301 (byte-compile-two-args form)) 3511 (byte-compile-two-args form))
3302 3512
3303(defun byte-compile-funarg (form)
3304 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
3305 ;; for cases where it's guaranteed that first arg will be used as a lambda.
3306 (byte-compile-normal-call
3307 (let ((fn (nth 1 form)))
3308 (if (and (eq (car-safe fn) 'quote)
3309 (eq (car-safe (nth 1 fn)) 'lambda))
3310 (cons (car form)
3311 (cons (cons 'function (cdr fn))
3312 (cdr (cdr form))))
3313 form))))
3314
3315(defun byte-compile-funarg-2 (form)
3316 ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..)))
3317 ;; for cases where it's guaranteed that second arg will be used as a lambda.
3318 (byte-compile-normal-call
3319 (let ((fn (nth 2 form)))
3320 (if (and (eq (car-safe fn) 'quote)
3321 (eq (car-safe (nth 1 fn)) 'lambda))
3322 (cons (car form)
3323 (cons (nth 1 form)
3324 (cons (cons 'function (cdr fn))
3325 (cdr (cdr (cdr form))))))
3326 form))))
3327
3328;; (function foo) must compile like 'foo, not like (symbol-function 'foo). 3513;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
3329;; Otherwise it will be incompatible with the interpreter, 3514;; Otherwise it will be incompatible with the interpreter,
3330;; and (funcall (function foo)) will lose with autoloads. 3515;; and (funcall (function foo)) will lose with autoloads.
3331 3516
3332(defun byte-compile-function-form (form) 3517(defun byte-compile-function-form (form)
3333 (byte-compile-constant 3518 (byte-compile-constant (if (symbolp (nth 1 form))
3334 (cond ((symbolp (nth 1 form)) 3519 (nth 1 form)
3335 (nth 1 form)) 3520 (byte-compile-lambda (nth 1 form)))))
3336 ((byte-compile-lambda (nth 1 form))))))
3337 3521
3338(defun byte-compile-indent-to (form) 3522(defun byte-compile-indent-to (form)
3339 (let ((len (length form))) 3523 (let ((len (length form)))
@@ -3368,20 +3552,19 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3368(byte-defop-compiler-1 setq) 3552(byte-defop-compiler-1 setq)
3369(byte-defop-compiler-1 setq-default) 3553(byte-defop-compiler-1 setq-default)
3370(byte-defop-compiler-1 quote) 3554(byte-defop-compiler-1 quote)
3371(byte-defop-compiler-1 quote-form)
3372 3555
3373(defun byte-compile-setq (form) 3556(defun byte-compile-setq (form)
3374 (let ((bytecomp-args (cdr form))) 3557 (let ((args (cdr form)))
3375 (if bytecomp-args 3558 (if args
3376 (while bytecomp-args 3559 (while args
3377 (byte-compile-form (car (cdr bytecomp-args))) 3560 (byte-compile-form (car (cdr args)))
3378 (or for-effect (cdr (cdr bytecomp-args)) 3561 (or byte-compile--for-effect (cdr (cdr args))
3379 (byte-compile-out 'byte-dup 0)) 3562 (byte-compile-out 'byte-dup 0))
3380 (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) 3563 (byte-compile-variable-set (car args))
3381 (setq bytecomp-args (cdr (cdr bytecomp-args)))) 3564 (setq args (cdr (cdr args))))
3382 ;; (setq), with no arguments. 3565 ;; (setq), with no arguments.
3383 (byte-compile-form nil for-effect)) 3566 (byte-compile-form nil byte-compile--for-effect))
3384 (setq for-effect nil))) 3567 (setq byte-compile--for-effect nil)))
3385 3568
3386(defun byte-compile-setq-default (form) 3569(defun byte-compile-setq-default (form)
3387 (setq form (cdr form)) 3570 (setq form (cdr form))
@@ -3412,26 +3595,22 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3412 3595
3413(defun byte-compile-quote (form) 3596(defun byte-compile-quote (form)
3414 (byte-compile-constant (car (cdr form)))) 3597 (byte-compile-constant (car (cdr form))))
3415
3416(defun byte-compile-quote-form (form)
3417 (byte-compile-constant (byte-compile-top-level (nth 1 form))))
3418
3419 3598
3420;;; control structures 3599;;; control structures
3421 3600
3422(defun byte-compile-body (bytecomp-body &optional for-effect) 3601(defun byte-compile-body (body &optional for-effect)
3423 (while (cdr bytecomp-body) 3602 (while (cdr body)
3424 (byte-compile-form (car bytecomp-body) t) 3603 (byte-compile-form (car body) t)
3425 (setq bytecomp-body (cdr bytecomp-body))) 3604 (setq body (cdr body)))
3426 (byte-compile-form (car bytecomp-body) for-effect)) 3605 (byte-compile-form (car body) for-effect))
3427 3606
3428(defsubst byte-compile-body-do-effect (bytecomp-body) 3607(defsubst byte-compile-body-do-effect (body)
3429 (byte-compile-body bytecomp-body for-effect) 3608 (byte-compile-body body byte-compile--for-effect)
3430 (setq for-effect nil)) 3609 (setq byte-compile--for-effect nil))
3431 3610
3432(defsubst byte-compile-form-do-effect (form) 3611(defsubst byte-compile-form-do-effect (form)
3433 (byte-compile-form form for-effect) 3612 (byte-compile-form form byte-compile--for-effect)
3434 (setq for-effect nil)) 3613 (setq byte-compile--for-effect nil))
3435 3614
3436(byte-defop-compiler-1 inline byte-compile-progn) 3615(byte-defop-compiler-1 inline byte-compile-progn)
3437(byte-defop-compiler-1 progn) 3616(byte-defop-compiler-1 progn)
@@ -3443,18 +3622,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
3443(byte-defop-compiler-1 or) 3622(byte-defop-compiler-1 or)
3444(byte-defop-compiler-1 while) 3623(byte-defop-compiler-1 while)
3445(byte-defop-compiler-1 funcall) 3624(byte-defop-compiler-1 funcall)
3446(byte-defop-compiler-1 apply byte-compile-funarg)
3447(byte-defop-compiler-1 mapcar byte-compile-funarg)
3448(byte-defop-compiler-1 mapatoms byte-compile-funarg)
3449(byte-defop-compiler-1 mapconcat byte-compile-funarg)
3450(byte-defop-compiler-1 mapc byte-compile-funarg)
3451(byte-defop-compiler-1 maphash byte-compile-funarg)
3452(byte-defop-compiler-1 map-char-table byte-compile-funarg)
3453(byte-defop-compiler-1 map-char-table byte-compile-funarg-2)
3454;; map-charset-chars should be funarg but has optional third arg
3455(byte-defop-compiler-1 sort byte-compile-funarg-2)
3456(byte-defop-compiler-1 let) 3625(byte-defop-compiler-1 let)
3457(byte-defop-compiler-1 let*) 3626(byte-defop-compiler-1 let* byte-compile-let)
3458 3627
3459(defun byte-compile-progn (form) 3628(defun byte-compile-progn (form)
3460 (byte-compile-body-do-effect (cdr form))) 3629 (byte-compile-body-do-effect (cdr form)))
@@ -3519,13 +3688,11 @@ that suppresses all warnings during execution of BODY."
3519 ,condition (list 'boundp 'default-boundp))) 3688 ,condition (list 'boundp 'default-boundp)))
3520 ;; Maybe add to the bound list. 3689 ;; Maybe add to the bound list.
3521 (byte-compile-bound-variables 3690 (byte-compile-bound-variables
3522 (if bound-list 3691 (append bound-list byte-compile-bound-variables)))
3523 (append bound-list byte-compile-bound-variables)
3524 byte-compile-bound-variables)))
3525 (unwind-protect 3692 (unwind-protect
3526 ;; If things not being bound at all is ok, so must them being obsolete. 3693 ;; If things not being bound at all is ok, so must them being
3527 ;; Note that we add to the existing lists since Tramp (ab)uses 3694 ;; obsolete. Note that we add to the existing lists since Tramp
3528 ;; this feature. 3695 ;; (ab)uses this feature.
3529 (let ((byte-compile-not-obsolete-vars 3696 (let ((byte-compile-not-obsolete-vars
3530 (append byte-compile-not-obsolete-vars bound-list)) 3697 (append byte-compile-not-obsolete-vars bound-list))
3531 (byte-compile-not-obsolete-funcs 3698 (byte-compile-not-obsolete-funcs
@@ -3547,20 +3714,20 @@ that suppresses all warnings during execution of BODY."
3547 (if (null (nthcdr 3 form)) 3714 (if (null (nthcdr 3 form))
3548 ;; No else-forms 3715 ;; No else-forms
3549 (progn 3716 (progn
3550 (byte-compile-goto-if nil for-effect donetag) 3717 (byte-compile-goto-if nil byte-compile--for-effect donetag)
3551 (byte-compile-maybe-guarded clause 3718 (byte-compile-maybe-guarded clause
3552 (byte-compile-form (nth 2 form) for-effect)) 3719 (byte-compile-form (nth 2 form) byte-compile--for-effect))
3553 (byte-compile-out-tag donetag)) 3720 (byte-compile-out-tag donetag))
3554 (let ((elsetag (byte-compile-make-tag))) 3721 (let ((elsetag (byte-compile-make-tag)))
3555 (byte-compile-goto 'byte-goto-if-nil elsetag) 3722 (byte-compile-goto 'byte-goto-if-nil elsetag)
3556 (byte-compile-maybe-guarded clause 3723 (byte-compile-maybe-guarded clause
3557 (byte-compile-form (nth 2 form) for-effect)) 3724 (byte-compile-form (nth 2 form) byte-compile--for-effect))
3558 (byte-compile-goto 'byte-goto donetag) 3725 (byte-compile-goto 'byte-goto donetag)
3559 (byte-compile-out-tag elsetag) 3726 (byte-compile-out-tag elsetag)
3560 (byte-compile-maybe-guarded (list 'not clause) 3727 (byte-compile-maybe-guarded (list 'not clause)
3561 (byte-compile-body (cdr (cdr (cdr form))) for-effect)) 3728 (byte-compile-body (cdr (cdr (cdr form))) byte-compile--for-effect))
3562 (byte-compile-out-tag donetag)))) 3729 (byte-compile-out-tag donetag))))
3563 (setq for-effect nil)) 3730 (setq byte-compile--for-effect nil))
3564 3731
3565(defun byte-compile-cond (clauses) 3732(defun byte-compile-cond (clauses)
3566 (let ((donetag (byte-compile-make-tag)) 3733 (let ((donetag (byte-compile-make-tag))
@@ -3577,18 +3744,18 @@ that suppresses all warnings during execution of BODY."
3577 (byte-compile-form (car clause)) 3744 (byte-compile-form (car clause))
3578 (if (null (cdr clause)) 3745 (if (null (cdr clause))
3579 ;; First clause is a singleton. 3746 ;; First clause is a singleton.
3580 (byte-compile-goto-if t for-effect donetag) 3747 (byte-compile-goto-if t byte-compile--for-effect donetag)
3581 (setq nexttag (byte-compile-make-tag)) 3748 (setq nexttag (byte-compile-make-tag))
3582 (byte-compile-goto 'byte-goto-if-nil nexttag) 3749 (byte-compile-goto 'byte-goto-if-nil nexttag)
3583 (byte-compile-maybe-guarded (car clause) 3750 (byte-compile-maybe-guarded (car clause)
3584 (byte-compile-body (cdr clause) for-effect)) 3751 (byte-compile-body (cdr clause) byte-compile--for-effect))
3585 (byte-compile-goto 'byte-goto donetag) 3752 (byte-compile-goto 'byte-goto donetag)
3586 (byte-compile-out-tag nexttag))))) 3753 (byte-compile-out-tag nexttag)))))
3587 ;; Last clause 3754 ;; Last clause
3588 (let ((guard (car clause))) 3755 (let ((guard (car clause)))
3589 (and (cdr clause) (not (eq guard t)) 3756 (and (cdr clause) (not (eq guard t))
3590 (progn (byte-compile-form guard) 3757 (progn (byte-compile-form guard)
3591 (byte-compile-goto-if nil for-effect donetag) 3758 (byte-compile-goto-if nil byte-compile--for-effect donetag)
3592 (setq clause (cdr clause)))) 3759 (setq clause (cdr clause))))
3593 (byte-compile-maybe-guarded guard 3760 (byte-compile-maybe-guarded guard
3594 (byte-compile-body-do-effect clause))) 3761 (byte-compile-body-do-effect clause)))
@@ -3596,10 +3763,10 @@ that suppresses all warnings during execution of BODY."
3596 3763
3597(defun byte-compile-and (form) 3764(defun byte-compile-and (form)
3598 (let ((failtag (byte-compile-make-tag)) 3765 (let ((failtag (byte-compile-make-tag))
3599 (bytecomp-args (cdr form))) 3766 (args (cdr form)))
3600 (if (null bytecomp-args) 3767 (if (null args)
3601 (byte-compile-form-do-effect t) 3768 (byte-compile-form-do-effect t)
3602 (byte-compile-and-recursion bytecomp-args failtag)))) 3769 (byte-compile-and-recursion args failtag))))
3603 3770
3604;; Handle compilation of a nontrivial `and' call. 3771;; Handle compilation of a nontrivial `and' call.
3605;; We use tail recursion so we can use byte-compile-maybe-guarded. 3772;; We use tail recursion so we can use byte-compile-maybe-guarded.
@@ -3607,7 +3774,7 @@ that suppresses all warnings during execution of BODY."
3607 (if (cdr rest) 3774 (if (cdr rest)
3608 (progn 3775 (progn
3609 (byte-compile-form (car rest)) 3776 (byte-compile-form (car rest))
3610 (byte-compile-goto-if nil for-effect failtag) 3777 (byte-compile-goto-if nil byte-compile--for-effect failtag)
3611 (byte-compile-maybe-guarded (car rest) 3778 (byte-compile-maybe-guarded (car rest)
3612 (byte-compile-and-recursion (cdr rest) failtag))) 3779 (byte-compile-and-recursion (cdr rest) failtag)))
3613 (byte-compile-form-do-effect (car rest)) 3780 (byte-compile-form-do-effect (car rest))
@@ -3615,10 +3782,10 @@ that suppresses all warnings during execution of BODY."
3615 3782
3616(defun byte-compile-or (form) 3783(defun byte-compile-or (form)
3617 (let ((wintag (byte-compile-make-tag)) 3784 (let ((wintag (byte-compile-make-tag))
3618 (bytecomp-args (cdr form))) 3785 (args (cdr form)))
3619 (if (null bytecomp-args) 3786 (if (null args)
3620 (byte-compile-form-do-effect nil) 3787 (byte-compile-form-do-effect nil)
3621 (byte-compile-or-recursion bytecomp-args wintag)))) 3788 (byte-compile-or-recursion args wintag))))
3622 3789
3623;; Handle compilation of a nontrivial `or' call. 3790;; Handle compilation of a nontrivial `or' call.
3624;; We use tail recursion so we can use byte-compile-maybe-guarded. 3791;; We use tail recursion so we can use byte-compile-maybe-guarded.
@@ -3626,7 +3793,7 @@ that suppresses all warnings during execution of BODY."
3626 (if (cdr rest) 3793 (if (cdr rest)
3627 (progn 3794 (progn
3628 (byte-compile-form (car rest)) 3795 (byte-compile-form (car rest))
3629 (byte-compile-goto-if t for-effect wintag) 3796 (byte-compile-goto-if t byte-compile--for-effect wintag)
3630 (byte-compile-maybe-guarded (list 'not (car rest)) 3797 (byte-compile-maybe-guarded (list 'not (car rest))
3631 (byte-compile-or-recursion (cdr rest) wintag))) 3798 (byte-compile-or-recursion (cdr rest) wintag)))
3632 (byte-compile-form-do-effect (car rest)) 3799 (byte-compile-form-do-effect (car rest))
@@ -3637,44 +3804,131 @@ that suppresses all warnings during execution of BODY."
3637 (looptag (byte-compile-make-tag))) 3804 (looptag (byte-compile-make-tag)))
3638 (byte-compile-out-tag looptag) 3805 (byte-compile-out-tag looptag)
3639 (byte-compile-form (car (cdr form))) 3806 (byte-compile-form (car (cdr form)))
3640 (byte-compile-goto-if nil for-effect endtag) 3807 (byte-compile-goto-if nil byte-compile--for-effect endtag)
3641 (byte-compile-body (cdr (cdr form)) t) 3808 (byte-compile-body (cdr (cdr form)) t)
3642 (byte-compile-goto 'byte-goto looptag) 3809 (byte-compile-goto 'byte-goto looptag)
3643 (byte-compile-out-tag endtag) 3810 (byte-compile-out-tag endtag)
3644 (setq for-effect nil))) 3811 (setq byte-compile--for-effect nil)))
3645 3812
3646(defun byte-compile-funcall (form) 3813(defun byte-compile-funcall (form)
3647 (mapc 'byte-compile-form (cdr form)) 3814 (mapc 'byte-compile-form (cdr form))
3648 (byte-compile-out 'byte-call (length (cdr (cdr form))))) 3815 (byte-compile-out 'byte-call (length (cdr (cdr form)))))
3649 3816
3817
3818;; let binding
3819
3820(defun byte-compile-push-binding-init (clause)
3821 "Emit byte-codes to push the initialization value for CLAUSE on the stack.
3822Return the offset in the form (VAR . OFFSET)."
3823 (let* ((var (if (consp clause) (car clause) clause)))
3824 ;; We record the stack position even of dynamic bindings and
3825 ;; variables in non-stack lexical environments; we'll put
3826 ;; them in the proper place below.
3827 (prog1 (cons var byte-compile-depth)
3828 (if (consp clause)
3829 (byte-compile-form (cadr clause))
3830 (byte-compile-push-constant nil)))))
3831
3832(defun byte-compile-not-lexical-var-p (var)
3833 (or (not (symbolp var))
3834 (special-variable-p var)
3835 (memq var byte-compile-bound-variables)
3836 (memq var '(nil t))
3837 (keywordp var)))
3838
3839(defun byte-compile-bind (var init-lexenv)
3840 "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
3841INIT-LEXENV should be a lexical-environment alist describing the
3842positions of the init value that have been pushed on the stack.
3843Return non-nil if the TOS value was popped."
3844 ;; The presence of lexical bindings mean that we may have to
3845 ;; juggle things on the stack, to move them to TOS for
3846 ;; dynamic binding.
3847 (cond ((not (byte-compile-not-lexical-var-p var))
3848 ;; VAR is a simple stack-allocated lexical variable
3849 (push (assq var init-lexenv)
3850 byte-compile--lexical-environment)
3851 nil)
3852 ((eq var (caar init-lexenv))
3853 ;; VAR is dynamic and is on the top of the
3854 ;; stack, so we can just bind it like usual
3855 (byte-compile-dynamic-variable-bind var)
3856 t)
3857 (t
3858 ;; VAR is dynamic, but we have to get its
3859 ;; value out of the middle of the stack
3860 (let ((stack-pos (cdr (assq var init-lexenv))))
3861 (byte-compile-stack-ref stack-pos)
3862 (byte-compile-dynamic-variable-bind var)
3863 ;; Now we have to store nil into its temporary
3864 ;; stack position to avoid problems with GC
3865 (byte-compile-push-constant nil)
3866 (byte-compile-stack-set stack-pos))
3867 nil)))
3868
3869(defun byte-compile-unbind (clauses init-lexenv
3870 &optional preserve-body-value)
3871 "Emit byte-codes to unbind the variables bound by CLAUSES.
3872CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a
3873lexical-environment alist describing the positions of the init value that
3874have been pushed on the stack. If PRESERVE-BODY-VALUE is true,
3875then an additional value on the top of the stack, above any lexical binding
3876slots, is preserved, so it will be on the top of the stack after all
3877binding slots have been popped."
3878 ;; Unbind dynamic variables
3879 (let ((num-dynamic-bindings 0))
3880 (dolist (clause clauses)
3881 (unless (assq (if (consp clause) (car clause) clause)
3882 byte-compile--lexical-environment)
3883 (setq num-dynamic-bindings (1+ num-dynamic-bindings))))
3884 (unless (zerop num-dynamic-bindings)
3885 (byte-compile-out 'byte-unbind num-dynamic-bindings)))
3886 ;; Pop lexical variables off the stack, possibly preserving the
3887 ;; return value of the body.
3888 (when init-lexenv
3889 ;; INIT-LEXENV contains all init values left on the stack
3890 (byte-compile-discard (length init-lexenv) preserve-body-value)))
3650 3891
3651(defun byte-compile-let (form) 3892(defun byte-compile-let (form)
3652 ;; First compute the binding values in the old scope. 3893 "Generate code for the `let' form FORM."
3653 (let ((varlist (car (cdr form)))) 3894 (let ((clauses (cadr form))
3654 (dolist (var varlist) 3895 (init-lexenv nil))
3655 (if (consp var) 3896 (when (eq (car form) 'let)
3656 (byte-compile-form (car (cdr var))) 3897 ;; First compute the binding values in the old scope.
3657 (byte-compile-push-constant nil)))) 3898 (dolist (var clauses)
3658 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope 3899 (push (byte-compile-push-binding-init var) init-lexenv)))
3659 (varlist (reverse (car (cdr form))))) 3900 ;; New scope.
3660 (dolist (var varlist) 3901 (let ((byte-compile-bound-variables byte-compile-bound-variables)
3661 (byte-compile-variable-ref 'byte-varbind 3902 (byte-compile--lexical-environment
3662 (if (consp var) (car var) var))) 3903 byte-compile--lexical-environment))
3663 (byte-compile-body-do-effect (cdr (cdr form))) 3904 ;; Bind the variables.
3664 (byte-compile-out 'byte-unbind (length (car (cdr form)))))) 3905 ;; For `let', do it in reverse order, because it makes no
3665 3906 ;; semantic difference, but it is a lot more efficient since the
3666(defun byte-compile-let* (form) 3907 ;; values are now in reverse order on the stack.
3667 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope 3908 (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses))
3668 (varlist (copy-sequence (car (cdr form))))) 3909 (unless (eq (car form) 'let)
3669 (dolist (var varlist) 3910 (push (byte-compile-push-binding-init var) init-lexenv))
3670 (if (atom var) 3911 (let ((var (if (consp var) (car var) var)))
3671 (byte-compile-push-constant nil) 3912 (cond ((null lexical-binding)
3672 (byte-compile-form (car (cdr var))) 3913 ;; If there are no lexical bindings, we can do things simply.
3673 (setq var (car var))) 3914 (byte-compile-dynamic-variable-bind var))
3674 (byte-compile-variable-ref 'byte-varbind var)) 3915 ((byte-compile-bind var init-lexenv)
3675 (byte-compile-body-do-effect (cdr (cdr form))) 3916 (pop init-lexenv)))))
3676 (byte-compile-out 'byte-unbind (length (car (cdr form)))))) 3917 ;; Emit the body.
3918 (let ((init-stack-depth byte-compile-depth))
3919 (byte-compile-body-do-effect (cdr (cdr form)))
3920 ;; Unbind the variables.
3921 (if lexical-binding
3922 ;; Unbind both lexical and dynamic variables.
3923 (progn
3924 (assert (or (eq byte-compile-depth init-stack-depth)
3925 (eq byte-compile-depth (1+ init-stack-depth))))
3926 (byte-compile-unbind clauses init-lexenv (> byte-compile-depth
3927 init-stack-depth)))
3928 ;; Unbind dynamic variables.
3929 (byte-compile-out 'byte-unbind (length clauses)))))))
3677 3930
3931
3678 3932
3679(byte-defop-compiler-1 /= byte-compile-negated) 3933(byte-defop-compiler-1 /= byte-compile-negated)
3680(byte-defop-compiler-1 atom byte-compile-negated) 3934(byte-defop-compiler-1 atom byte-compile-negated)
@@ -3706,70 +3960,86 @@ that suppresses all warnings during execution of BODY."
3706(byte-defop-compiler-1 save-excursion) 3960(byte-defop-compiler-1 save-excursion)
3707(byte-defop-compiler-1 save-current-buffer) 3961(byte-defop-compiler-1 save-current-buffer)
3708(byte-defop-compiler-1 save-restriction) 3962(byte-defop-compiler-1 save-restriction)
3709(byte-defop-compiler-1 save-window-excursion) 3963;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro.
3710(byte-defop-compiler-1 with-output-to-temp-buffer) 3964;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
3711(byte-defop-compiler-1 track-mouse) 3965(byte-defop-compiler-1 track-mouse)
3712 3966
3713(defun byte-compile-catch (form) 3967(defun byte-compile-catch (form)
3714 (byte-compile-form (car (cdr form))) 3968 (byte-compile-form (car (cdr form)))
3715 (byte-compile-push-constant 3969 (pcase (cddr form)
3716 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) 3970 (`(:fun-body ,f)
3971 (byte-compile-form `(list 'funcall ,f)))
3972 (body
3973 (byte-compile-push-constant
3974 (byte-compile-top-level (cons 'progn body) byte-compile--for-effect))))
3717 (byte-compile-out 'byte-catch 0)) 3975 (byte-compile-out 'byte-catch 0))
3718 3976
3719(defun byte-compile-unwind-protect (form) 3977(defun byte-compile-unwind-protect (form)
3720 (byte-compile-push-constant 3978 (pcase (cddr form)
3721 (byte-compile-top-level-body (cdr (cdr form)) t)) 3979 (`(:fun-body ,f)
3980 (byte-compile-form `(list (list 'funcall ,f))))
3981 (handlers
3982 (byte-compile-push-constant
3983 (byte-compile-top-level-body handlers t))))
3722 (byte-compile-out 'byte-unwind-protect 0) 3984 (byte-compile-out 'byte-unwind-protect 0)
3723 (byte-compile-form-do-effect (car (cdr form))) 3985 (byte-compile-form-do-effect (car (cdr form)))
3724 (byte-compile-out 'byte-unbind 1)) 3986 (byte-compile-out 'byte-unbind 1))
3725 3987
3726(defun byte-compile-track-mouse (form) 3988(defun byte-compile-track-mouse (form)
3727 (byte-compile-form 3989 (byte-compile-form
3728 `(funcall '(lambda nil 3990 (pcase form
3729 (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) 3991 (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f))))
3992 (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form))))))))
3730 3993
3731(defun byte-compile-condition-case (form) 3994(defun byte-compile-condition-case (form)
3732 (let* ((var (nth 1 form)) 3995 (let* ((var (nth 1 form))
3733 (byte-compile-bound-variables 3996 (fun-bodies (eq var :fun-body))
3734 (if var (cons var byte-compile-bound-variables) 3997 (byte-compile-bound-variables
3998 (if (and var (not fun-bodies))
3999 (cons var byte-compile-bound-variables)
3735 byte-compile-bound-variables))) 4000 byte-compile-bound-variables)))
3736 (byte-compile-set-symbol-position 'condition-case) 4001 (byte-compile-set-symbol-position 'condition-case)
3737 (unless (symbolp var) 4002 (unless (symbolp var)
3738 (byte-compile-warn 4003 (byte-compile-warn
3739 "`%s' is not a variable-name or nil (in condition-case)" var)) 4004 "`%s' is not a variable-name or nil (in condition-case)" var))
4005 (if fun-bodies (setq var (make-symbol "err")))
3740 (byte-compile-push-constant var) 4006 (byte-compile-push-constant var)
3741 (byte-compile-push-constant (byte-compile-top-level 4007 (if fun-bodies
3742 (nth 2 form) for-effect)) 4008 (byte-compile-form `(list 'funcall ,(nth 2 form)))
3743 (let ((clauses (cdr (cdr (cdr form)))) 4009 (byte-compile-push-constant
3744 compiled-clauses) 4010 (byte-compile-top-level (nth 2 form) byte-compile--for-effect)))
3745 (while clauses 4011 (let ((compiled-clauses
3746 (let* ((clause (car clauses)) 4012 (mapcar
3747 (condition (car clause))) 4013 (lambda (clause)
3748 (cond ((not (or (symbolp condition) 4014 (let ((condition (car clause)))
3749 (and (listp condition) 4015 (cond ((not (or (symbolp condition)
3750 (let ((syms condition) (ok t)) 4016 (and (listp condition)
3751 (while syms 4017 (let ((ok t))
3752 (if (not (symbolp (car syms))) 4018 (dolist (sym condition)
3753 (setq ok nil)) 4019 (if (not (symbolp sym))
3754 (setq syms (cdr syms))) 4020 (setq ok nil)))
3755 ok)))) 4021 ok))))
3756 (byte-compile-warn 4022 (byte-compile-warn
3757 "`%s' is not a condition name or list of such (in condition-case)" 4023 "`%S' is not a condition name or list of such (in condition-case)"
3758 (prin1-to-string condition))) 4024 condition))
3759;; ((not (or (eq condition 't) 4025 ;; (not (or (eq condition 't)
3760;; (and (stringp (get condition 'error-message)) 4026 ;; (and (stringp (get condition 'error-message))
3761;; (consp (get condition 'error-conditions))))) 4027 ;; (consp (get condition
3762;; (byte-compile-warn 4028 ;; 'error-conditions)))))
3763;; "`%s' is not a known condition name (in condition-case)" 4029 ;; (byte-compile-warn
3764;; condition)) 4030 ;; "`%s' is not a known condition name
3765 ) 4031 ;; (in condition-case)"
3766 (setq compiled-clauses 4032 ;; condition))
3767 (cons (cons condition 4033 )
3768 (byte-compile-top-level-body 4034 (if fun-bodies
3769 (cdr clause) for-effect)) 4035 `(list ',condition (list 'funcall ,(cadr clause) ',var))
3770 compiled-clauses))) 4036 (cons condition
3771 (setq clauses (cdr clauses))) 4037 (byte-compile-top-level-body
3772 (byte-compile-push-constant (nreverse compiled-clauses))) 4038 (cdr clause) byte-compile--for-effect)))))
4039 (cdr (cdr (cdr form))))))
4040 (if fun-bodies
4041 (byte-compile-form `(list ,@compiled-clauses))
4042 (byte-compile-push-constant compiled-clauses)))
3773 (byte-compile-out 'byte-condition-case 0))) 4043 (byte-compile-out 'byte-condition-case 0)))
3774 4044
3775 4045
@@ -3791,17 +4061,6 @@ that suppresses all warnings during execution of BODY."
3791 (byte-compile-out 'byte-save-current-buffer 0) 4061 (byte-compile-out 'byte-save-current-buffer 0)
3792 (byte-compile-body-do-effect (cdr form)) 4062 (byte-compile-body-do-effect (cdr form))
3793 (byte-compile-out 'byte-unbind 1)) 4063 (byte-compile-out 'byte-unbind 1))
3794
3795(defun byte-compile-save-window-excursion (form)
3796 (byte-compile-push-constant
3797 (byte-compile-top-level-body (cdr form) for-effect))
3798 (byte-compile-out 'byte-save-window-excursion 0))
3799
3800(defun byte-compile-with-output-to-temp-buffer (form)
3801 (byte-compile-form (car (cdr form)))
3802 (byte-compile-out 'byte-temp-output-buffer-setup 0)
3803 (byte-compile-body (cdr (cdr form)))
3804 (byte-compile-out 'byte-temp-output-buffer-show 0))
3805 4064
3806;;; top-level forms elsewhere 4065;;; top-level forms elsewhere
3807 4066
@@ -3818,22 +4077,16 @@ that suppresses all warnings during execution of BODY."
3818 (byte-compile-set-symbol-position (car form)) 4077 (byte-compile-set-symbol-position (car form))
3819 (byte-compile-set-symbol-position 'defun) 4078 (byte-compile-set-symbol-position 'defun)
3820 (error "defun name must be a symbol, not %s" (car form))) 4079 (error "defun name must be a symbol, not %s" (car form)))
3821 ;; We prefer to generate a defalias form so it will record the function 4080 (byte-compile-push-constant 'defalias)
3822 ;; definition just like interpreting a defun. 4081 (byte-compile-push-constant (nth 1 form))
3823 (byte-compile-form 4082 (byte-compile-push-constant (byte-compile-lambda (cdr (cdr form)) t))
3824 (list 'defalias 4083 (byte-compile-out 'byte-call 2))
3825 (list 'quote (nth 1 form))
3826 (byte-compile-byte-code-maker
3827 (byte-compile-lambda (cdr (cdr form)) t)))
3828 t)
3829 (byte-compile-constant (nth 1 form)))
3830 4084
3831(defun byte-compile-defmacro (form) 4085(defun byte-compile-defmacro (form)
3832 ;; This is not used for file-level defmacros with doc strings. 4086 ;; This is not used for file-level defmacros with doc strings.
3833 (byte-compile-body-do-effect 4087 (byte-compile-body-do-effect
3834 (let ((decls (byte-compile-defmacro-declaration form)) 4088 (let ((decls (byte-compile-defmacro-declaration form))
3835 (code (byte-compile-byte-code-maker 4089 (code (byte-compile-lambda (cdr (cdr form)) t)))
3836 (byte-compile-lambda (cdr (cdr form)) t))))
3837 `((defalias ',(nth 1 form) 4090 `((defalias ',(nth 1 form)
3838 ,(if (eq (car-safe code) 'make-byte-code) 4091 ,(if (eq (car-safe code) 'make-byte-code)
3839 `(cons 'macro ,code) 4092 `(cons 'macro ,code)
@@ -3881,7 +4134,7 @@ that suppresses all warnings during execution of BODY."
3881 ;; Put the defined variable in this library's load-history entry 4134 ;; Put the defined variable in this library's load-history entry
3882 ;; just as a real defvar would, but only in top-level forms. 4135 ;; just as a real defvar would, but only in top-level forms.
3883 (when (and (cddr form) (null byte-compile-current-form)) 4136 (when (and (cddr form) (null byte-compile-current-form))
3884 `(push ',var current-load-list)) 4137 `(setq current-load-list (cons ',var current-load-list)))
3885 (when (> (length form) 3) 4138 (when (> (length form) 3)
3886 (when (and string (not (stringp string))) 4139 (when (and string (not (stringp string)))
3887 (byte-compile-warn "third arg to `%s %s' is not a string: %s" 4140 (byte-compile-warn "third arg to `%s %s' is not a string: %s"
@@ -3915,7 +4168,7 @@ that suppresses all warnings during execution of BODY."
3915 4168
3916;; Lambdas in valid places are handled as special cases by various code. 4169;; Lambdas in valid places are handled as special cases by various code.
3917;; The ones that remain are errors. 4170;; The ones that remain are errors.
3918(defun byte-compile-lambda-form (form) 4171(defun byte-compile-lambda-form (_form)
3919 (byte-compile-set-symbol-position 'lambda) 4172 (byte-compile-set-symbol-position 'lambda)
3920 (error "`lambda' used as function name is invalid")) 4173 (error "`lambda' used as function name is invalid"))
3921 4174
@@ -3990,8 +4243,8 @@ that suppresses all warnings during execution of BODY."
3990 (progn 4243 (progn
3991 ;; ## remove this someday 4244 ;; ## remove this someday
3992 (and byte-compile-depth 4245 (and byte-compile-depth
3993 (not (= (cdr (cdr tag)) byte-compile-depth)) 4246 (not (= (cdr (cdr tag)) byte-compile-depth))
3994 (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) 4247 (error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
3995 (setq byte-compile-depth (cdr (cdr tag)))) 4248 (setq byte-compile-depth (cdr (cdr tag))))
3996 (setcdr (cdr tag) byte-compile-depth))) 4249 (setcdr (cdr tag) byte-compile-depth)))
3997 4250
@@ -4003,24 +4256,31 @@ that suppresses all warnings during execution of BODY."
4003 (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) 4256 (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
4004 (1- byte-compile-depth)))) 4257 (1- byte-compile-depth))))
4005 4258
4006(defun byte-compile-out (opcode offset) 4259(defun byte-compile-stack-adjustment (op operand)
4007 (push (cons opcode offset) byte-compile-output) 4260 "Return the amount by which an operation adjusts the stack.
4008 (cond ((eq opcode 'byte-call) 4261OP and OPERAND are as passed to `byte-compile-out'."
4009 (setq byte-compile-depth (- byte-compile-depth offset))) 4262 (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos))
4010 ((eq opcode 'byte-return) 4263 ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1
4011 ;; This is actually an unnecessary case, because there should be 4264 ;; elements, and the push the result, for a total of -OPERAND.
4012 ;; no more opcodes behind byte-return. 4265 ;; For discardN*, of course, we just pop OPERAND elements.
4013 (setq byte-compile-depth nil)) 4266 (- operand)
4014 (t 4267 (or (aref byte-stack+-info (symbol-value op))
4015 (setq byte-compile-depth (+ byte-compile-depth 4268 ;; Ops with a nil entry in `byte-stack+-info' are byte-codes
4016 (or (aref byte-stack+-info 4269 ;; that take OPERAND values off the stack and push a result, for
4017 (symbol-value opcode)) 4270 ;; a total of 1 - OPERAND
4018 (- (1- offset)))) 4271 (- 1 operand))))
4019 byte-compile-maxdepth (max byte-compile-depth 4272
4020 byte-compile-maxdepth)))) 4273(defun byte-compile-out (op &optional operand)
4021 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) 4274 (push (cons op operand) byte-compile-output)
4022 ) 4275 (if (eq op 'byte-return)
4023 4276 ;; This is actually an unnecessary case, because there should be no
4277 ;; more ops behind byte-return.
4278 (setq byte-compile-depth nil)
4279 (setq byte-compile-depth
4280 (+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
4281 (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
4282 ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
4283 ))
4024 4284
4025;;; call tree stuff 4285;;; call tree stuff
4026 4286
@@ -4079,22 +4339,22 @@ invoked interactively."
4079 (if byte-compile-call-tree-sort 4339 (if byte-compile-call-tree-sort
4080 (setq byte-compile-call-tree 4340 (setq byte-compile-call-tree
4081 (sort byte-compile-call-tree 4341 (sort byte-compile-call-tree
4082 (cond ((eq byte-compile-call-tree-sort 'callers) 4342 (case byte-compile-call-tree-sort
4083 (function (lambda (x y) (< (length (nth 1 x)) 4343 (callers
4084 (length (nth 1 y)))))) 4344 (lambda (x y) (< (length (nth 1 x))
4085 ((eq byte-compile-call-tree-sort 'calls) 4345 (length (nth 1 y)))))
4086 (function (lambda (x y) (< (length (nth 2 x)) 4346 (calls
4087 (length (nth 2 y)))))) 4347 (lambda (x y) (< (length (nth 2 x))
4088 ((eq byte-compile-call-tree-sort 'calls+callers) 4348 (length (nth 2 y)))))
4089 (function (lambda (x y) (< (+ (length (nth 1 x)) 4349 (calls+callers
4090 (length (nth 2 x))) 4350 (lambda (x y) (< (+ (length (nth 1 x))
4091 (+ (length (nth 1 y)) 4351 (length (nth 2 x)))
4092 (length (nth 2 y))))))) 4352 (+ (length (nth 1 y))
4093 ((eq byte-compile-call-tree-sort 'name) 4353 (length (nth 2 y))))))
4094 (function (lambda (x y) (string< (car x) 4354 (name
4095 (car y))))) 4355 (lambda (x y) (string< (car x) (car y))))
4096 (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" 4356 (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
4097 byte-compile-call-tree-sort)))))) 4357 byte-compile-call-tree-sort))))))
4098 (message "Generating call tree...") 4358 (message "Generating call tree...")
4099 (let ((rest byte-compile-call-tree) 4359 (let ((rest byte-compile-call-tree)
4100 (b (current-buffer)) 4360 (b (current-buffer))
@@ -4202,60 +4462,59 @@ Each file is processed even if an error occurred previously.
4202For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". 4462For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\".
4203If NOFORCE is non-nil, don't recompile a file that seems to be 4463If NOFORCE is non-nil, don't recompile a file that seems to be
4204already up-to-date." 4464already up-to-date."
4205 ;; command-line-args-left is what is left of the command line (from startup.el) 4465 ;; command-line-args-left is what is left of the command line, from
4466 ;; startup.el.
4206 (defvar command-line-args-left) ;Avoid 'free variable' warning 4467 (defvar command-line-args-left) ;Avoid 'free variable' warning
4207 (if (not noninteractive) 4468 (if (not noninteractive)
4208 (error "`batch-byte-compile' is to be used only with -batch")) 4469 (error "`batch-byte-compile' is to be used only with -batch"))
4209 (let ((bytecomp-error nil)) 4470 (let ((error nil))
4210 (while command-line-args-left 4471 (while command-line-args-left
4211 (if (file-directory-p (expand-file-name (car command-line-args-left))) 4472 (if (file-directory-p (expand-file-name (car command-line-args-left)))
4212 ;; Directory as argument. 4473 ;; Directory as argument.
4213 (let ((bytecomp-files (directory-files (car command-line-args-left))) 4474 (let (source dest)
4214 bytecomp-source bytecomp-dest) 4475 (dolist (file (directory-files (car command-line-args-left)))
4215 (dolist (bytecomp-file bytecomp-files) 4476 (if (and (string-match emacs-lisp-file-regexp file)
4216 (if (and (string-match emacs-lisp-file-regexp bytecomp-file) 4477 (not (auto-save-file-name-p file))
4217 (not (auto-save-file-name-p bytecomp-file)) 4478 (setq source
4218 (setq bytecomp-source 4479 (expand-file-name file
4219 (expand-file-name bytecomp-file
4220 (car command-line-args-left))) 4480 (car command-line-args-left)))
4221 (setq bytecomp-dest (byte-compile-dest-file 4481 (setq dest (byte-compile-dest-file source))
4222 bytecomp-source)) 4482 (file-exists-p dest)
4223 (file-exists-p bytecomp-dest) 4483 (file-newer-than-file-p source dest))
4224 (file-newer-than-file-p bytecomp-source bytecomp-dest)) 4484 (if (null (batch-byte-compile-file source))
4225 (if (null (batch-byte-compile-file bytecomp-source)) 4485 (setq error t)))))
4226 (setq bytecomp-error t)))))
4227 ;; Specific file argument 4486 ;; Specific file argument
4228 (if (or (not noforce) 4487 (if (or (not noforce)
4229 (let* ((bytecomp-source (car command-line-args-left)) 4488 (let* ((source (car command-line-args-left))
4230 (bytecomp-dest (byte-compile-dest-file bytecomp-source))) 4489 (dest (byte-compile-dest-file source)))
4231 (or (not (file-exists-p bytecomp-dest)) 4490 (or (not (file-exists-p dest))
4232 (file-newer-than-file-p bytecomp-source bytecomp-dest)))) 4491 (file-newer-than-file-p source dest))))
4233 (if (null (batch-byte-compile-file (car command-line-args-left))) 4492 (if (null (batch-byte-compile-file (car command-line-args-left)))
4234 (setq bytecomp-error t)))) 4493 (setq error t))))
4235 (setq command-line-args-left (cdr command-line-args-left))) 4494 (setq command-line-args-left (cdr command-line-args-left)))
4236 (kill-emacs (if bytecomp-error 1 0)))) 4495 (kill-emacs (if error 1 0))))
4237 4496
4238(defun batch-byte-compile-file (bytecomp-file) 4497(defun batch-byte-compile-file (file)
4239 (if debug-on-error 4498 (if debug-on-error
4240 (byte-compile-file bytecomp-file) 4499 (byte-compile-file file)
4241 (condition-case err 4500 (condition-case err
4242 (byte-compile-file bytecomp-file) 4501 (byte-compile-file file)
4243 (file-error 4502 (file-error
4244 (message (if (cdr err) 4503 (message (if (cdr err)
4245 ">>Error occurred processing %s: %s (%s)" 4504 ">>Error occurred processing %s: %s (%s)"
4246 ">>Error occurred processing %s: %s") 4505 ">>Error occurred processing %s: %s")
4247 bytecomp-file 4506 file
4248 (get (car err) 'error-message) 4507 (get (car err) 'error-message)
4249 (prin1-to-string (cdr err))) 4508 (prin1-to-string (cdr err)))
4250 (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) 4509 (let ((destfile (byte-compile-dest-file file)))
4251 (if (file-exists-p bytecomp-destfile) 4510 (if (file-exists-p destfile)
4252 (delete-file bytecomp-destfile))) 4511 (delete-file destfile)))
4253 nil) 4512 nil)
4254 (error 4513 (error
4255 (message (if (cdr err) 4514 (message (if (cdr err)
4256 ">>Error occurred processing %s: %s (%s)" 4515 ">>Error occurred processing %s: %s (%s)"
4257 ">>Error occurred processing %s: %s") 4516 ">>Error occurred processing %s: %s")
4258 bytecomp-file 4517 file
4259 (get (car err) 'error-message) 4518 (get (car err) 'error-message)
4260 (prin1-to-string (cdr err))) 4519 (prin1-to-string (cdr err)))
4261 nil)))) 4520 nil))))
@@ -4271,7 +4530,14 @@ Use with caution."
4271 (setq f (car f)) 4530 (setq f (car f))
4272 (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) 4531 (if (string-match "elc\\'" f) (setq f (substring f 0 -1)))
4273 (when (and (file-readable-p f) 4532 (when (and (file-readable-p f)
4274 (file-newer-than-file-p f emacs-file)) 4533 (file-newer-than-file-p f emacs-file)
4534 ;; Don't reload the source version of the files below
4535 ;; because that causes subsequent byte-compilation to
4536 ;; be a lot slower and need a higher max-lisp-eval-depth,
4537 ;; so it can cause recompilation to fail.
4538 (not (member (file-name-nondirectory f)
4539 '("pcase.el" "bytecomp.el" "macroexp.el"
4540 "cconv.el" "byte-opt.el"))))
4275 (message "Reloading stale %s" (file-name-nondirectory f)) 4541 (message "Reloading stale %s" (file-name-nondirectory f))
4276 (condition-case nil 4542 (condition-case nil
4277 (load f 'noerror nil 'nosuffix) 4543 (load f 'noerror nil 'nosuffix)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
new file mode 100644
index 00000000000..5cc9ecb4cf7
--- /dev/null
+++ b/lisp/emacs-lisp/cconv.el
@@ -0,0 +1,713 @@
1;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
2
3;; Copyright (C) 2011 Free Software Foundation, Inc.
4
5;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
6;; Maintainer: FSF
7;; Keywords: lisp
8;; Package: emacs
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; This takes a piece of Elisp code, and eliminates all free variables from
28;; lambda expressions. The user entry points are cconv-closure-convert and
29;; cconv-closure-convert-toplevel(for toplevel forms).
30;; All macros should be expanded beforehand.
31;;
32;; Here is a brief explanation how this code works.
33;; Firstly, we analyse the tree by calling cconv-analyse-form.
34;; This function finds all mutated variables, all functions that are suitable
35;; for lambda lifting and all variables captured by closure. It passes the tree
36;; once, returning a list of three lists.
37;;
38;; Then we calculate the intersection of first and third lists returned by
39;; cconv-analyse form to find all mutated variables that are captured by
40;; closure.
41
42;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
43;; tree recursivly, lifting lambdas where possible, building closures where it
44;; is needed and eliminating mutable variables used in closure.
45;;
46;; We do following replacements :
47;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
48;; if the function is suitable for lambda lifting (if all calls are known)
49;;
50;; (lambda (v0 ...) ... fv0 .. fv1 ...) =>
51;; (internal-make-closure (v0 ...) (fv1 ...)
52;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...)
53;;
54;; If the function has no free variables, we don't do anything.
55;;
56;; If a variable is mutated (updated by setq), and it is used in a closure
57;; we wrap its definition with list: (list val) and we also replace
58;; var => (car var) wherever this variable is used, and also
59;; (setq var value) => (setcar var value) where it is updated.
60;;
61;; If defun argument is closure mutable, we letbind it and wrap it's
62;; definition with list.
63;; (defun foo (... mutable-arg ...) ...) =>
64;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
65;;
66;;; Code:
67
68;; TODO: (not just for cconv but also for the lexbind changes in general)
69;; - let (e)debug find the value of lexical variables from the stack.
70;; - make eval-region do the eval-sexp-add-defvars danse.
71;; - byte-optimize-form should be applied before cconv.
72;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
73;; since afterwards they can because obnoxious (warnings about an "unused
74;; variable" should not be emitted when the variable use has simply been
75;; optimized away).
76;; - turn defun and defmacro into macros (and remove special handling of
77;; `declare' afterwards).
78;; - let macros specify that some let-bindings come from the same source,
79;; so the unused warning takes all uses into account.
80;; - let interactive specs return a function to build the args (to stash into
81;; command-history).
82;; - canonize code in macro-expand so we don't have to handle (let (var) body)
83;; and other oddities.
84;; - new byte codes for unwind-protect, catch, and condition-case so that
85;; closures aren't needed at all.
86;; - inline source code of different binding mode by first compiling it.
87;; - a reference to a var that is known statically to always hold a constant
88;; should be turned into a byte-constant rather than a byte-stack-ref.
89;; Hmm... right, that's called constant propagation and could be done here,
90;; but when that constant is a function, we have to be careful to make sure
91;; the bytecomp only compiles it once.
92;; - Since we know here when a variable is not mutated, we could pass that
93;; info to the byte-compiler, e.g. by using a new `immutable-let'.
94;; - add tail-calls to bytecode.c and the byte compiler.
95;; - call known non-escaping functions with `goto' rather than `call'.
96;; - optimize mapcar to a while loop.
97
98;; (defmacro dlet (binders &rest body)
99;; ;; Works in both lexical and non-lexical mode.
100;; `(progn
101;; ,@(mapcar (lambda (binder)
102;; `(defvar ,(if (consp binder) (car binder) binder)))
103;; binders)
104;; (let ,binders ,@body)))
105
106;; (defmacro llet (binders &rest body)
107;; ;; Only works in lexical-binding mode.
108;; `(funcall
109;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
110;; binders)
111;; ,@body)
112;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
113;; binders)))
114
115;; (defmacro letrec (binders &rest body)
116;; ;; Only useful in lexical-binding mode.
117;; ;; As a special-form, we could implement it more efficiently (and cleanly,
118;; ;; making the vars actually unbound during evaluation of the binders).
119;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
120;; binders)
121;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder)))
122;; binders))
123;; ,@body))
124
125(eval-when-compile (require 'cl))
126
127(defconst cconv-liftwhen 6
128 "Try to do lambda lifting if the number of arguments + free variables
129is less than this number.")
130;; List of all the variables that are both captured by a closure
131;; and mutated. Each entry in the list takes the form
132;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
133;; variable (or is just (VAR) for variables not introduced by let).
134(defvar cconv-captured+mutated)
135
136;; List of candidates for lambda lifting.
137;; Each candidate has the form (BINDER . PARENTFORM). A candidate
138;; is a variable that is only passed to `funcall' or `apply'.
139(defvar cconv-lambda-candidates)
140
141;; Alist associating to each function body the list of its free variables.
142(defvar cconv-freevars-alist)
143
144;;;###autoload
145(defun cconv-closure-convert (form)
146 "Main entry point for closure conversion.
147-- FORM is a piece of Elisp code after macroexpansion.
148-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
149
150Returns a form where all lambdas don't have any free variables."
151 ;; (message "Entering cconv-closure-convert...")
152 (let ((cconv-freevars-alist '())
153 (cconv-lambda-candidates '())
154 (cconv-captured+mutated '()))
155 ;; Analyse form - fill these variables with new information.
156 (cconv-analyse-form form '())
157 (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
158 (cconv-convert form nil nil))) ; Env initially empty.
159
160(defconst cconv--dummy-var (make-symbol "ignored"))
161
162(defun cconv--set-diff (s1 s2)
163 "Return elements of set S1 that are not in set S2."
164 (let ((res '()))
165 (dolist (x s1)
166 (unless (memq x s2) (push x res)))
167 (nreverse res)))
168
169(defun cconv--set-diff-map (s m)
170 "Return elements of set S that are not in Dom(M)."
171 (let ((res '()))
172 (dolist (x s)
173 (unless (assq x m) (push x res)))
174 (nreverse res)))
175
176(defun cconv--map-diff (m1 m2)
177 "Return the submap of map M1 that has Dom(M2) removed."
178 (let ((res '()))
179 (dolist (x m1)
180 (unless (assq (car x) m2) (push x res)))
181 (nreverse res)))
182
183(defun cconv--map-diff-elem (m x)
184 "Return the map M minus any mapping for X."
185 ;; Here we assume that X appears at most once in M.
186 (let* ((b (assq x m))
187 (res (if b (remq b m) m)))
188 (assert (null (assq x res))) ;; Check the assumption was warranted.
189 res))
190
191(defun cconv--map-diff-set (m s)
192 "Return the map M minus any mapping for elements of S."
193 ;; Here we assume that X appears at most once in M.
194 (let ((res '()))
195 (dolist (b m)
196 (unless (memq (car b) s) (push b res)))
197 (nreverse res)))
198
199(defun cconv--convert-function (args body env parentform)
200 (assert (equal body (caar cconv-freevars-alist)))
201 (let* ((fvs (cdr (pop cconv-freevars-alist)))
202 (body-new '())
203 (letbind '())
204 (envector ())
205 (i 0)
206 (new-env ()))
207 ;; Build the "formal and actual envs" for the closure-converted function.
208 (dolist (fv fvs)
209 (let ((exp (or (cdr (assq fv env)) fv)))
210 (pcase exp
211 ;; If `fv' is a variable that's wrapped in a cons-cell,
212 ;; we want to put the cons-cell itself in the closure,
213 ;; rather than just a copy of its current content.
214 (`(car ,iexp . ,_)
215 (push iexp envector)
216 (push `(,fv . (car (internal-get-closed-var ,i))) new-env))
217 (_
218 (push exp envector)
219 (push `(,fv . (internal-get-closed-var ,i)) new-env))))
220 (setq i (1+ i)))
221 (setq envector (nreverse envector))
222 (setq new-env (nreverse new-env))
223
224 (dolist (arg args)
225 (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
226 (if (assq arg new-env) (push `(,arg) new-env))
227 (push `(,arg . (car ,arg)) new-env)
228 (push `(,arg (list ,arg)) letbind)))
229
230 (setq body-new (mapcar (lambda (form)
231 (cconv-convert form new-env nil))
232 body))
233
234 (when letbind
235 (let ((special-forms '()))
236 ;; Keep special forms at the beginning of the body.
237 (while (or (stringp (car body-new)) ;docstring.
238 (memq (car-safe (car body-new)) '(interactive declare)))
239 (push (pop body-new) special-forms))
240 (setq body-new
241 `(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
242
243 (cond
244 ((null envector) ;if no freevars - do nothing
245 `(function (lambda ,args . ,body-new)))
246 (t
247 `(internal-make-closure
248 ,args ,envector . ,body-new)))))
249
250(defun cconv-convert (form env extend)
251 ;; This function actually rewrites the tree.
252 "Return FORM with all its lambdas changed so they are closed.
253ENV is a lexical environment mapping variables to the expression
254used to get its value. This is used for variables that are copied into
255closures, moved into cons cells, ...
256ENV is a list where each entry takes the shape either:
257 (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP
258 is an expression that evaluates to this cons-cell.
259 (VAR . (internal-get-closed-var N)): VAR has been copied into the closure
260 environment's Nth slot.
261 (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
262 additional arguments ARGs.
263EXTEND is a list of variables which might need to be accessed even from places
264where they are shadowed, because some part of ENV causes them to be used at
265places where they originally did not directly appear."
266 (assert (not (delq nil (mapcar (lambda (mapping)
267 (if (eq (cadr mapping) 'apply-partially)
268 (cconv--set-diff (cdr (cddr mapping))
269 extend)))
270 env))))
271
272 ;; What's the difference between fvrs and envs?
273 ;; Suppose that we have the code
274 ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
275 ;; only the first occurrence of fvr should be replaced by
276 ;; (aref env ...).
277 ;; So initially envs and fvrs are the same thing, but when we descend to
278 ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
279 ;; Because in envs the order of variables is important. We use this list
280 ;; to find the number of a specific variable in the environment vector,
281 ;; so we never touch it(unless we enter to the other closure).
282 ;;(if (listp form) (print (car form)) form)
283 (pcase form
284 (`(,(and letsym (or `let* `let)) ,binders . ,body)
285
286 ; let and let* special forms
287 (let ((binders-new '())
288 (new-env env)
289 (new-extend extend))
290
291 (dolist (binder binders)
292 (let* ((value nil)
293 (var (if (not (consp binder))
294 (prog1 binder (setq binder (list binder)))
295 (setq value (cadr binder))
296 (car binder)))
297 (new-val
298 (cond
299 ;; Check if var is a candidate for lambda lifting.
300 ((and (member (cons binder form) cconv-lambda-candidates)
301 (progn
302 (assert (and (eq (car value) 'function)
303 (eq (car (cadr value)) 'lambda)))
304 (assert (equal (cddr (cadr value))
305 (caar cconv-freevars-alist)))
306 ;; Peek at the freevars to decide whether to λ-lift.
307 (let* ((fvs (cdr (car cconv-freevars-alist)))
308 (fun (cadr value))
309 (funargs (cadr fun))
310 (funcvars (append fvs funargs)))
311 ; lambda lifting condition
312 (and fvs (>= cconv-liftwhen (length funcvars))))))
313 ; Lift.
314 (let* ((fvs (cdr (pop cconv-freevars-alist)))
315 (fun (cadr value))
316 (funargs (cadr fun))
317 (funcvars (append fvs funargs))
318 (funcbody (cddr fun))
319 (funcbody-env ()))
320 (push `(,var . (apply-partially ,var . ,fvs)) new-env)
321 (dolist (fv fvs)
322 (pushnew fv new-extend)
323 (if (and (eq 'car (car-safe (cdr (assq fv env))))
324 (not (memq fv funargs)))
325 (push `(,fv . (car ,fv)) funcbody-env)))
326 `(function (lambda ,funcvars .
327 ,(mapcar (lambda (form)
328 (cconv-convert
329 form funcbody-env nil))
330 funcbody)))))
331
332 ;; Check if it needs to be turned into a "ref-cell".
333 ((member (cons binder form) cconv-captured+mutated)
334 ;; Declared variable is mutated and captured.
335 (push `(,var . (car ,var)) new-env)
336 `(list ,(cconv-convert value env extend)))
337
338 ;; Normal default case.
339 (t
340 (if (assq var new-env) (push `(,var) new-env))
341 (cconv-convert value env extend)))))
342
343 ;; The piece of code below letbinds free variables of a λ-lifted
344 ;; function if they are redefined in this let, example:
345 ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
346 ;; Here we can not pass y as parameter because it is redefined.
347 ;; So we add a (closed-y y) declaration. We do that even if the
348 ;; function is not used inside this let(*). The reason why we
349 ;; ignore this case is that we can't "look forward" to see if the
350 ;; function is called there or not. To treat this case better we'd
351 ;; need to traverse the tree one more time to collect this data, and
352 ;; I think that it's not worth it.
353 (when (memq var new-extend)
354 (let ((closedsym
355 (make-symbol (concat "closed-" (symbol-name var)))))
356 (setq new-env
357 (mapcar (lambda (mapping)
358 (if (not (eq (cadr mapping) 'apply-partially))
359 mapping
360 (assert (eq (car mapping) (nth 2 mapping)))
361 (list* (car mapping)
362 'apply-partially
363 (car mapping)
364 (mapcar (lambda (arg)
365 (if (eq var arg)
366 closedsym arg))
367 (nthcdr 3 mapping)))))
368 new-env))
369 (setq new-extend (remq var new-extend))
370 (push closedsym new-extend)
371 (push `(,closedsym ,var) binders-new)))
372
373 ;; We push the element after redefined free variables are
374 ;; processed. This is important to avoid the bug when free
375 ;; variable and the function have the same name.
376 (push (list var new-val) binders-new)
377
378 (when (eq letsym 'let*)
379 (setq env new-env)
380 (setq extend new-extend))
381 )) ; end of dolist over binders
382
383 `(,letsym ,(nreverse binders-new)
384 . ,(mapcar (lambda (form)
385 (cconv-convert
386 form new-env new-extend))
387 body))))
388 ;end of let let* forms
389
390 ; first element is lambda expression
391 (`(,(and `(lambda . ,_) fun) . ,args)
392 ;; FIXME: it's silly to create a closure just to call it.
393 ;; Running byte-optimize-form earlier will resolve this.
394 `(funcall
395 ,(cconv-convert `(function ,fun) env extend)
396 ,@(mapcar (lambda (form)
397 (cconv-convert form env extend))
398 args)))
399
400 (`(cond . ,cond-forms) ; cond special form
401 `(cond . ,(mapcar (lambda (branch)
402 (mapcar (lambda (form)
403 (cconv-convert form env extend))
404 branch))
405 cond-forms)))
406
407 (`(function (lambda ,args . ,body) . ,_)
408 (cconv--convert-function args body env form))
409
410 (`(internal-make-closure . ,_)
411 (byte-compile-report-error
412 "Internal error in compiler: cconv called twice?"))
413
414 (`(quote . ,_) form)
415 (`(function . ,_) form)
416
417 ;defconst, defvar
418 (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms)
419 `(,sym ,definedsymbol
420 . ,(mapcar (lambda (form) (cconv-convert form env extend))
421 forms)))
422
423 ;defun, defmacro
424 (`(,(and sym (or `defun `defmacro))
425 ,func ,args . ,body)
426 (assert (equal body (caar cconv-freevars-alist)))
427 (assert (null (cdar cconv-freevars-alist)))
428
429 (let ((new (cconv--convert-function args body env form)))
430 (pcase new
431 (`(function (lambda ,newargs . ,new-body))
432 (assert (equal args newargs))
433 `(,sym ,func ,args . ,new-body))
434 (t (byte-compile-report-error
435 (format "Internal error in cconv of (%s %s ...)" sym func))))))
436
437 ;condition-case
438 (`(condition-case ,var ,protected-form . ,handlers)
439 (let ((newform (cconv--convert-function
440 () (list protected-form) env form)))
441 `(condition-case :fun-body ,newform
442 ,@(mapcar (lambda (handler)
443 (list (car handler)
444 (cconv--convert-function
445 (list (or var cconv--dummy-var))
446 (cdr handler) env form)))
447 handlers))))
448
449 (`(,(and head (or `catch `unwind-protect)) ,form . ,body)
450 `(,head ,(cconv-convert form env extend)
451 :fun-body ,(cconv--convert-function () body env form)))
452
453 (`(track-mouse . ,body)
454 `(track-mouse
455 :fun-body ,(cconv--convert-function () body env form)))
456
457 (`(setq . ,forms) ; setq special form
458 (let ((prognlist ()))
459 (while forms
460 (let* ((sym (pop forms))
461 (sym-new (or (cdr (assq sym env)) sym))
462 (value (cconv-convert (pop forms) env extend)))
463 (push (pcase sym-new
464 ((pred symbolp) `(setq ,sym-new ,value))
465 (`(car ,iexp) `(setcar ,iexp ,value))
466 ;; This "should never happen", but for variables which are
467 ;; mutated+captured+unused, we may end up trying to `setq'
468 ;; on a closed-over variable, so just drop the setq.
469 (_ ;; (byte-compile-report-error
470 ;; (format "Internal error in cconv of (setq %s ..)"
471 ;; sym-new))
472 value))
473 prognlist)))
474 (if (cdr prognlist)
475 `(progn . ,(nreverse prognlist))
476 (car prognlist))))
477
478 (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
479 ;; These are not special forms but we treat them separately for the needs
480 ;; of lambda lifting.
481 (let ((mapping (cdr (assq fun env))))
482 (pcase mapping
483 (`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
484 (assert (eq (cadr mapping) fun))
485 `(,callsym ,fun
486 ,@(mapcar (lambda (fv)
487 (let ((exp (or (cdr (assq fv env)) fv)))
488 (pcase exp
489 (`(car ,iexp . ,_) iexp)
490 (_ exp))))
491 fvs)
492 ,@(mapcar (lambda (arg)
493 (cconv-convert arg env extend))
494 args)))
495 (_ `(,callsym ,@(mapcar (lambda (arg)
496 (cconv-convert arg env extend))
497 (cons fun args)))))))
498
499 (`(interactive . ,forms)
500 `(interactive . ,(mapcar (lambda (form)
501 (cconv-convert form nil nil))
502 forms)))
503
504 (`(declare . ,_) form) ;The args don't contain code.
505
506 (`(,func . ,forms)
507 ;; First element is function or whatever function-like forms are: or, and,
508 ;; if, progn, prog1, prog2, while, until
509 `(,func . ,(mapcar (lambda (form)
510 (cconv-convert form env extend))
511 forms)))
512
513 (_ (or (cdr (assq form env)) form))))
514
515(unless (fboundp 'byte-compile-not-lexical-var-p)
516 ;; Only used to test the code in non-lexbind Emacs.
517 (defalias 'byte-compile-not-lexical-var-p 'boundp))
518
519(defun cconv--analyse-use (vardata form varkind)
520 "Analyse the use of a variable.
521VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
522VARKIND is the name of the kind of variable.
523FORM is the parent form that binds this var."
524 ;; use = `(,binder ,read ,mutated ,captured ,called)
525 (pcase vardata
526 (`(,_ nil nil nil nil) nil)
527 (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_)
528 ,_ ,_ ,_ ,_)
529 (byte-compile-log-warning
530 (format "%s `%S' not left unused" varkind var))))
531 (pcase vardata
532 (`((,var . ,_) nil ,_ ,_ nil)
533 ;; FIXME: This gives warnings in the wrong order, with imprecise line
534 ;; numbers and without function name info.
535 (unless (or ;; Uninterned symbols typically come from macro-expansion, so
536 ;; it is often non-trivial for the programmer to avoid such
537 ;; unused vars.
538 (not (intern-soft var))
539 (eq ?_ (aref (symbol-name var) 0)))
540 (byte-compile-log-warning (format "Unused lexical %s `%S'"
541 varkind var))))
542 ;; If it's unused, there's no point converting it into a cons-cell, even if
543 ;; it's captured and mutated.
544 (`(,binder ,_ t t ,_)
545 (push (cons binder form) cconv-captured+mutated))
546 (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
547 (push (cons binder form) cconv-lambda-candidates))))
548
549(defun cconv--analyse-function (args body env parentform)
550 (let* ((newvars nil)
551 (freevars (list body))
552 ;; We analyze the body within a new environment where all uses are
553 ;; nil, so we can distinguish uses within that function from uses
554 ;; outside of it.
555 (envcopy
556 (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
557 (newenv envcopy))
558 ;; Push it before recursing, so cconv-freevars-alist contains entries in
559 ;; the order they'll be used by closure-convert-rec.
560 (push freevars cconv-freevars-alist)
561 (dolist (arg args)
562 (cond
563 ((byte-compile-not-lexical-var-p arg)
564 (byte-compile-log-warning
565 (format "Argument %S is not a lexical variable" arg)))
566 ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
567 (t (let ((varstruct (list arg nil nil nil nil)))
568 (push (cons (list arg) (cdr varstruct)) newvars)
569 (push varstruct newenv)))))
570 (dolist (form body) ;Analyse body forms.
571 (cconv-analyse-form form newenv))
572 ;; Summarize resulting data about arguments.
573 (dolist (vardata newvars)
574 (cconv--analyse-use vardata parentform "argument"))
575 ;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
576 ;; and compute free variables.
577 (while env
578 (assert (and envcopy (eq (caar env) (caar envcopy))))
579 (let ((free nil)
580 (x (cdr (car env)))
581 (y (cdr (car envcopy))))
582 (while x
583 (when (car y) (setcar x t) (setq free t))
584 (setq x (cdr x) y (cdr y)))
585 (when free
586 (push (caar env) (cdr freevars))
587 (setf (nth 3 (car env)) t))
588 (setq env (cdr env) envcopy (cdr envcopy))))))
589
590(defun cconv-analyse-form (form env)
591 "Find mutated variables and variables captured by closure.
592Analyse lambdas if they are suitable for lambda lifting.
593- FORM is a piece of Elisp code after macroexpansion.
594- ENV is an alist mapping each enclosing lexical variable to its info.
595 I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
596This function does not return anything but instead fills the
597`cconv-captured+mutated' and `cconv-lambda-candidates' variables
598and updates the data stored in ENV."
599 (pcase form
600 ; let special form
601 (`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
602
603 (let ((orig-env env)
604 (newvars nil)
605 (var nil)
606 (value nil))
607 (dolist (binder binders)
608 (if (not (consp binder))
609 (progn
610 (setq var binder) ; treat the form (let (x) ...) well
611 (setq binder (list binder))
612 (setq value nil))
613 (setq var (car binder))
614 (setq value (cadr binder))
615
616 (cconv-analyse-form value (if (eq letsym 'let*) env orig-env)))
617
618 (unless (byte-compile-not-lexical-var-p var)
619 (let ((varstruct (list var nil nil nil nil)))
620 (push (cons binder (cdr varstruct)) newvars)
621 (push varstruct env))))
622
623 (dolist (form body-forms) ; Analyse body forms.
624 (cconv-analyse-form form env))
625
626 (dolist (vardata newvars)
627 (cconv--analyse-use vardata form "variable"))))
628
629 ; defun special form
630 (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
631 (when env
632 (byte-compile-log-warning
633 (format "Function %S will ignore its context %S"
634 func (mapcar #'car env))
635 t :warning))
636 (cconv--analyse-function vrs body-forms nil form))
637
638 (`(function (lambda ,vrs . ,body-forms))
639 (cconv--analyse-function vrs body-forms env form))
640
641 (`(setq . ,forms)
642 ;; If a local variable (member of env) is modified by setq then
643 ;; it is a mutated variable.
644 (while forms
645 (let ((v (assq (car forms) env))) ; v = non nil if visible
646 (when v (setf (nth 2 v) t)))
647 (cconv-analyse-form (cadr forms) env)
648 (setq forms (cddr forms))))
649
650 (`((lambda . ,_) . ,_) ; first element is lambda expression
651 (dolist (exp `((function ,(car form)) . ,(cdr form)))
652 (cconv-analyse-form exp env)))
653
654 (`(cond . ,cond-forms) ; cond special form
655 (dolist (forms cond-forms)
656 (dolist (form forms) (cconv-analyse-form form env))))
657
658 (`(quote . ,_) nil) ; quote form
659 (`(function . ,_) nil) ; same as quote
660
661 (`(condition-case ,var ,protected-form . ,handlers)
662 ;; FIXME: The bytecode for condition-case forces us to wrap the
663 ;; form and handlers in closures (for handlers, it's understandable
664 ;; but not for the protected form).
665 (cconv--analyse-function () (list protected-form) env form)
666 (dolist (handler handlers)
667 (cconv--analyse-function (if var (list var)) (cdr handler) env form)))
668
669 ;; FIXME: The bytecode for catch forces us to wrap the body.
670 (`(,(or `catch `unwind-protect) ,form . ,body)
671 (cconv-analyse-form form env)
672 (cconv--analyse-function () body env form))
673
674 ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
675 ;; `track-mouse' really should be made into a macro.
676 (`(track-mouse . ,body)
677 (cconv--analyse-function () body env form))
678
679 (`(,(or `defconst `defvar) ,var ,value . ,_)
680 (push var byte-compile-bound-variables)
681 (cconv-analyse-form value env))
682
683 (`(,(or `funcall `apply) ,fun . ,args)
684 ;; Here we ignore fun because funcall and apply are the only two
685 ;; functions where we can pass a candidate for lambda lifting as
686 ;; argument. So, if we see fun elsewhere, we'll delete it from
687 ;; lambda candidate list.
688 (let ((fdata (and (symbolp fun) (assq fun env))))
689 (if fdata
690 (setf (nth 4 fdata) t)
691 (cconv-analyse-form fun env)))
692 (dolist (form args) (cconv-analyse-form form env)))
693
694 (`(interactive . ,forms)
695 ;; These appear within the function body but they don't have access
696 ;; to the function's arguments.
697 ;; We could extend this to allow interactive specs to refer to
698 ;; variables in the function's enclosing environment, but it doesn't
699 ;; seem worth the trouble.
700 (dolist (form forms) (cconv-analyse-form form nil)))
701
702 (`(declare . ,_) nil) ;The args don't contain code.
703
704 (`(,_ . ,body-forms) ; First element is a function or whatever.
705 (dolist (form body-forms) (cconv-analyse-form form env)))
706
707 ((pred symbolp)
708 (let ((dv (assq form env))) ; dv = declared and visible
709 (when dv
710 (setf (nth 1 dv) t))))))
711
712(provide 'cconv)
713;;; cconv.el ends here
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 885424ec726..7468a0237cf 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -766,20 +766,15 @@ This also does some trivial optimizations to make the form prettier."
766 (eq (car-safe (car body)) 'interactive)) 766 (eq (car-safe (car body)) 'interactive))
767 (push (list 'quote (pop body)) decls)) 767 (push (list 'quote (pop body)) decls))
768 (put (car (last cl-closure-vars)) 'used t) 768 (put (car (last cl-closure-vars)) 'used t)
769 (append 769 `(list 'lambda '(&rest --cl-rest--)
770 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) 770 ,@(sublis sub (nreverse decls))
771 (sublis sub (nreverse decls)) 771 (list 'apply
772 (list 772 (list 'quote
773 (list* 'list '(quote apply) 773 #'(lambda ,(append new (cadadr form))
774 (list 'function 774 ,@(sublis sub body)))
775 (list* 'lambda 775 ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
776 (append new (cadadr form)) 776 cl-closure-vars)
777 (sublis sub body))) 777 '((quote --cl-rest--))))))
778 (nconc (mapcar (function
779 (lambda (x)
780 (list 'list '(quote quote) x)))
781 cl-closure-vars)
782 '((quote --cl-rest--)))))))
783 (list (car form) (list* 'lambda (cadadr form) body)))) 778 (list (car form) (list* 'lambda (cadadr form) body))))
784 (let ((found (assq (cadr form) env))) 779 (let ((found (assq (cadr form) env)))
785 (if (and found (ignore-errors 780 (if (and found (ignore-errors
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 08001171ed1..4c824d4a6d4 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -10,7 +10,7 @@
10;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p 10;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
11;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively 11;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
12;;;;;; notevery notany every some mapcon mapcan mapl maplist map 12;;;;;; notevery notany every some mapcon mapcan mapl maplist map
13;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6") 13;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84")
14;;; Generated autoloads from cl-extra.el 14;;; Generated autoloads from cl-extra.el
15 15
16(autoload 'coerce "cl-extra" "\ 16(autoload 'coerce "cl-extra" "\
@@ -277,12 +277,12 @@ Not documented
277;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct 277;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct
278;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf 278;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf
279;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method 279;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method
280;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let* 280;;;;;; declare the locally multiple-value-setq multiple-value-bind
281;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq 281;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels
282;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from 282;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
283;;;;;; return block etypecase typecase ecase case load-time-value 283;;;;;; do* do loop return-from return block etypecase typecase ecase
284;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp 284;;;;;; case load-time-value eval-when destructuring-bind function*
285;;;;;; gensym) "cl-macs" "cl-macs.el" "b3031039e82679e5b013ce1cbf174ee8") 285;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5")
286;;; Generated autoloads from cl-macs.el 286;;; Generated autoloads from cl-macs.el
287 287
288(autoload 'gensym "cl-macs" "\ 288(autoload 'gensym "cl-macs" "\
@@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions.
319\(fn FUNC)" nil (quote macro)) 319\(fn FUNC)" nil (quote macro))
320 320
321(autoload 'destructuring-bind "cl-macs" "\ 321(autoload 'destructuring-bind "cl-macs" "\
322Not documented 322
323 323
324\(fn ARGS EXPR &rest BODY)" nil (quote macro)) 324\(fn ARGS EXPR &rest BODY)" nil (quote macro))
325 325
@@ -445,7 +445,7 @@ from OBARRAY.
445\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) 445\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro))
446 446
447(autoload 'do-all-symbols "cl-macs" "\ 447(autoload 'do-all-symbols "cl-macs" "\
448Not documented 448
449 449
450\(fn SPEC &rest BODY)" nil (quote macro)) 450\(fn SPEC &rest BODY)" nil (quote macro))
451 451
@@ -500,16 +500,16 @@ Like `let', but lexically scoped.
500The main visible difference is that lambdas inside BODY will create 500The main visible difference is that lambdas inside BODY will create
501lexical closures as in Common Lisp. 501lexical closures as in Common Lisp.
502 502
503\(fn VARLIST BODY)" nil (quote macro)) 503\(fn BINDINGS BODY)" nil (quote macro))
504 504
505(autoload 'lexical-let* "cl-macs" "\ 505(autoload 'lexical-let* "cl-macs" "\
506Like `let*', but lexically scoped. 506Like `let*', but lexically scoped.
507The main visible difference is that lambdas inside BODY, and in 507The main visible difference is that lambdas inside BODY, and in
508successive bindings within VARLIST, will create lexical closures 508successive bindings within BINDINGS, will create lexical closures
509as in Common Lisp. This is similar to the behavior of `let*' in 509as in Common Lisp. This is similar to the behavior of `let*' in
510Common Lisp. 510Common Lisp.
511 511
512\(fn VARLIST BODY)" nil (quote macro)) 512\(fn BINDINGS BODY)" nil (quote macro))
513 513
514(autoload 'multiple-value-bind "cl-macs" "\ 514(autoload 'multiple-value-bind "cl-macs" "\
515Collect multiple return values. 515Collect multiple return values.
@@ -531,12 +531,17 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
531\(fn (SYM...) FORM)" nil (quote macro)) 531\(fn (SYM...) FORM)" nil (quote macro))
532 532
533(autoload 'locally "cl-macs" "\ 533(autoload 'locally "cl-macs" "\
534Not documented 534
535 535
536\(fn &rest BODY)" nil (quote macro)) 536\(fn &rest BODY)" nil (quote macro))
537 537
538(autoload 'the "cl-macs" "\
539
540
541\(fn TYPE FORM)" nil (quote macro))
542
538(autoload 'declare "cl-macs" "\ 543(autoload 'declare "cl-macs" "\
539Not documented 544
540 545
541\(fn &rest SPECS)" nil (quote macro)) 546\(fn &rest SPECS)" nil (quote macro))
542 547
@@ -596,7 +601,7 @@ before assigning any PLACEs to the corresponding values.
596\(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) 601\(fn PLACE VAL PLACE VAL ...)" nil (quote macro))
597 602
598(autoload 'cl-do-pop "cl-macs" "\ 603(autoload 'cl-do-pop "cl-macs" "\
599Not documented 604
600 605
601\(fn PLACE)" nil nil) 606\(fn PLACE)" nil nil)
602 607
@@ -684,7 +689,7 @@ value, that slot cannot be set via `setf'.
684\(fn NAME SLOTS...)" nil (quote macro)) 689\(fn NAME SLOTS...)" nil (quote macro))
685 690
686(autoload 'cl-struct-setf-expander "cl-macs" "\ 691(autoload 'cl-struct-setf-expander "cl-macs" "\
687Not documented 692
688 693
689\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) 694\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil)
690 695
@@ -730,7 +735,7 @@ and then returning foo.
730\(fn FUNC ARGS &rest BODY)" nil (quote macro)) 735\(fn FUNC ARGS &rest BODY)" nil (quote macro))
731 736
732(autoload 'compiler-macroexpand "cl-macs" "\ 737(autoload 'compiler-macroexpand "cl-macs" "\
733Not documented 738
734 739
735\(fn FORM)" nil nil) 740\(fn FORM)" nil nil)
736 741
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c57d37703b0..9ce3dd6a7fe 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
497 (symbol-function 'byte-compile-file-form))) 497 (symbol-function 'byte-compile-file-form)))
498 (list 'byte-compile-file-form (list 'quote set)) 498 (list 'byte-compile-file-form (list 'quote set))
499 '(byte-compile-file-form form))) 499 '(byte-compile-file-form form)))
500 (print set (symbol-value 'bytecomp-outbuffer))) 500 (print set (symbol-value 'byte-compile--outbuffer)))
501 (list 'symbol-value (list 'quote temp))) 501 (list 'symbol-value (list 'quote temp)))
502 (list 'quote (eval form)))) 502 (list 'quote (eval form))))
503 503
@@ -598,27 +598,6 @@ called from BODY."
598 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) 598 (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
599 body)))) 599 body))))
600 600
601(defvar cl-active-block-names nil)
602
603(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
604(defun cl-byte-compile-block (cl-form)
605 (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
606 (progn
607 (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
608 (cl-active-block-names (cons cl-entry cl-active-block-names))
609 (cl-body (byte-compile-top-level
610 (cons 'progn (cddr (nth 1 cl-form))))))
611 (if (cdr cl-entry)
612 (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
613 (byte-compile-form cl-body))))
614 (byte-compile-form (nth 1 cl-form))))
615
616(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
617(defun cl-byte-compile-throw (cl-form)
618 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
619 (if cl-found (setcdr cl-found t)))
620 (byte-compile-normal-call (cons 'throw (cdr cl-form))))
621
622;;;###autoload 601;;;###autoload
623(defmacro return (&optional result) 602(defmacro return (&optional result)
624 "Return from the block named nil. 603 "Return from the block named nil.
@@ -1427,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
1427 "Like `let', but lexically scoped. 1406 "Like `let', but lexically scoped.
1428The main visible difference is that lambdas inside BODY will create 1407The main visible difference is that lambdas inside BODY will create
1429lexical closures as in Common Lisp. 1408lexical closures as in Common Lisp.
1430\n(fn VARLIST BODY)" 1409\n(fn BINDINGS BODY)"
1431 (let* ((cl-closure-vars cl-closure-vars) 1410 (let* ((cl-closure-vars cl-closure-vars)
1432 (vars (mapcar (function 1411 (vars (mapcar (function
1433 (lambda (x) 1412 (lambda (x)
@@ -1470,10 +1449,10 @@ lexical closures as in Common Lisp.
1470(defmacro lexical-let* (bindings &rest body) 1449(defmacro lexical-let* (bindings &rest body)
1471 "Like `let*', but lexically scoped. 1450 "Like `let*', but lexically scoped.
1472The main visible difference is that lambdas inside BODY, and in 1451The main visible difference is that lambdas inside BODY, and in
1473successive bindings within VARLIST, will create lexical closures 1452successive bindings within BINDINGS, will create lexical closures
1474as in Common Lisp. This is similar to the behavior of `let*' in 1453as in Common Lisp. This is similar to the behavior of `let*' in
1475Common Lisp. 1454Common Lisp.
1476\n(fn VARLIST BODY)" 1455\n(fn BINDINGS BODY)"
1477 (if (null bindings) (cons 'progn body) 1456 (if (null bindings) (cons 'progn body)
1478 (setq bindings (reverse bindings)) 1457 (setq bindings (reverse bindings))
1479 (while bindings 1458 (while bindings
@@ -2422,11 +2401,13 @@ value, that slot cannot be set via `setf'.
2422 (push (cons name t) side-eff)))) 2401 (push (cons name t) side-eff))))
2423 (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) 2402 (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
2424 (if print-func 2403 (if print-func
2425 (push (list 'push 2404 (push `(push
2426 (list 'function 2405 ;; The auto-generated function does not pay attention to
2427 (list 'lambda '(cl-x cl-s cl-n) 2406 ;; the depth argument cl-n.
2428 (list 'and pred-form print-func))) 2407 (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
2429 'custom-print-functions) forms)) 2408 (and ,pred-form ,print-func))
2409 custom-print-functions)
2410 forms))
2430 (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) 2411 (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
2431 (push (list* 'eval-when '(compile load eval) 2412 (push (list* 'eval-when '(compile load eval)
2432 (list 'put (list 'quote name) '(quote cl-struct-slots) 2413 (list 'put (list 'quote name) '(quote cl-struct-slots)
@@ -2580,7 +2561,7 @@ and then returning foo."
2580 (cl-transform-function-property 2561 (cl-transform-function-property
2581 func 'cl-compiler-macro 2562 func 'cl-compiler-macro
2582 (cons (if (memq '&whole args) (delq '&whole args) 2563 (cons (if (memq '&whole args) (delq '&whole args)
2583 (cons '--cl-whole-arg-- args)) body)) 2564 (cons '_cl-whole-arg args)) body))
2584 (list 'or (list 'get (list 'quote func) '(quote byte-compile)) 2565 (list 'or (list 'get (list 'quote func) '(quote byte-compile))
2585 (list 'progn 2566 (list 'progn
2586 (list 'put (list 'quote func) '(quote byte-compile) 2567 (list 'put (list 'quote func) '(quote byte-compile)
@@ -2618,6 +2599,27 @@ and then returning foo."
2618 (byte-compile-normal-call form) 2599 (byte-compile-normal-call form)
2619 (byte-compile-form form))) 2600 (byte-compile-form form)))
2620 2601
2602;; Optimize away unused block-wrappers.
2603
2604(defvar cl-active-block-names nil)
2605
2606(define-compiler-macro cl-block-wrapper (cl-form)
2607 (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
2608 (cl-active-block-names (cons cl-entry cl-active-block-names))
2609 (cl-body (macroexpand-all ;Performs compiler-macro expansions.
2610 (cons 'progn (cddr cl-form))
2611 macroexpand-all-environment)))
2612 ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
2613 ;; to indicate that this return value is already fully expanded.
2614 (if (cdr cl-entry)
2615 `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
2616 cl-body)))
2617
2618(define-compiler-macro cl-block-throw (cl-tag cl-value)
2619 (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
2620 (if cl-found (setcdr cl-found t)))
2621 `(throw ,cl-tag ,cl-value))
2622
2621;;;###autoload 2623;;;###autoload
2622(defmacro defsubst* (name args &rest body) 2624(defmacro defsubst* (name args &rest body)
2623 "Define NAME as a function. 2625 "Define NAME as a function.
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index 1d2b82f82eb..526475eb1bd 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -161,7 +161,14 @@ an element already on the list.
161 (if (symbolp place) 161 (if (symbolp place)
162 (if (null keys) 162 (if (null keys)
163 `(let ((x ,x)) 163 `(let ((x ,x))
164 (if (memql x ,place) ,place (setq ,place (cons x ,place)))) 164 (if (memql x ,place)
165 ;; This symbol may later on expand to actual code which then
166 ;; trigger warnings like "value unused" since pushnew's return
167 ;; value is rarely used. It should not matter that other
168 ;; warnings may be silenced, since `place' is used earlier and
169 ;; should have triggered them already.
170 (with-no-warnings ,place)
171 (setq ,place (cons x ,place))))
165 (list 'setq place (list* 'adjoin x place keys))) 172 (list 'setq place (list* 'adjoin x place keys)))
166 (list* 'callf2 'adjoin x place keys))) 173 (list* 'callf2 'adjoin x place keys)))
167 174
@@ -271,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation.
271(defvar cl-compiling-file nil) 278(defvar cl-compiling-file nil)
272(defun cl-compiling-file () 279(defun cl-compiling-file ()
273 (or cl-compiling-file 280 (or cl-compiling-file
274 (and (boundp 'bytecomp-outbuffer) 281 (and (boundp 'byte-compile--outbuffer)
275 (bufferp (symbol-value 'bytecomp-outbuffer)) 282 (bufferp (symbol-value 'byte-compile--outbuffer))
276 (equal (buffer-name (symbol-value 'bytecomp-outbuffer)) 283 (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
277 " *Compiler Output*")))) 284 " *Compiler Output*"))))
278 285
279(defvar cl-proclaims-deferred nil) 286(defvar cl-proclaims-deferred nil)
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 9f4cca91676..4fd10185c17 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -78,13 +78,14 @@ redefine OBJECT if it is a symbol."
78 obj (symbol-function obj))) 78 obj (symbol-function obj)))
79 (if (subrp obj) 79 (if (subrp obj)
80 (error "Can't disassemble #<subr %s>" name)) 80 (error "Can't disassemble #<subr %s>" name))
81 (if (and (listp obj) (eq (car obj) 'autoload)) 81 (when (and (listp obj) (eq (car obj) 'autoload))
82 (progn 82 (load (nth 1 obj))
83 (load (nth 1 obj)) 83 (setq obj (symbol-function name)))
84 (setq obj (symbol-function name))))
85 (if (eq (car-safe obj) 'macro) ;handle macros 84 (if (eq (car-safe obj) 'macro) ;handle macros
86 (setq macro t 85 (setq macro t
87 obj (cdr obj))) 86 obj (cdr obj)))
87 (when (and (listp obj) (eq (car obj) 'closure))
88 (error "Don't know how to compile an interpreted closure"))
88 (if (and (listp obj) (eq (car obj) 'byte-code)) 89 (if (and (listp obj) (eq (car obj) 'byte-code))
89 (setq obj (list 'lambda nil obj))) 90 (setq obj (list 'lambda nil obj)))
90 (if (and (listp obj) (not (eq (car obj) 'lambda))) 91 (if (and (listp obj) (not (eq (car obj) 'lambda)))
@@ -215,7 +216,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
215 (cond ((memq op byte-goto-ops) 216 (cond ((memq op byte-goto-ops)
216 (insert (int-to-string (nth 1 arg)))) 217 (insert (int-to-string (nth 1 arg))))
217 ((memq op '(byte-call byte-unbind 218 ((memq op '(byte-call byte-unbind
218 byte-listN byte-concatN byte-insertN)) 219 byte-listN byte-concatN byte-insertN
220 byte-stack-ref byte-stack-set byte-stack-set2
221 byte-discardN byte-discardN-preserve-tos))
219 (insert (int-to-string arg))) 222 (insert (int-to-string arg)))
220 ((memq op '(byte-varref byte-varset byte-varbind)) 223 ((memq op '(byte-varref byte-varset byte-varbind))
221 (prin1 (car arg) (current-buffer))) 224 (prin1 (car arg) (current-buffer)))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 70a7983dbea..f84de0308bf 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -519,7 +519,8 @@ the minibuffer."
519 ((and (eq (car form) 'defcustom) 519 ((and (eq (car form) 'defcustom)
520 (default-boundp (nth 1 form))) 520 (default-boundp (nth 1 form)))
521 ;; Force variable to be bound. 521 ;; Force variable to be bound.
522 (set-default (nth 1 form) (eval (nth 2 form)))) 522 ;; FIXME: Shouldn't this use the :setter or :initializer?
523 (set-default (nth 1 form) (eval (nth 2 form) lexical-binding)))
523 ((eq (car form) 'defface) 524 ((eq (car form) 'defface)
524 ;; Reset the face. 525 ;; Reset the face.
525 (setq face-new-frame-defaults 526 (setq face-new-frame-defaults
@@ -532,7 +533,7 @@ the minibuffer."
532 (put ',(nth 1 form) 'customized-face 533 (put ',(nth 1 form) 'customized-face
533 ,(nth 2 form))) 534 ,(nth 2 form)))
534 (put (nth 1 form) 'saved-face nil))))) 535 (put (nth 1 form) 'saved-face nil)))))
535 (setq edebug-result (eval form)) 536 (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding))
536 (if (not edebugging) 537 (if (not edebugging)
537 (princ edebug-result) 538 (princ edebug-result)
538 edebug-result))) 539 edebug-result)))
@@ -565,7 +566,8 @@ already is one.)"
565 ;; but this causes problems while edebugging edebug. 566 ;; but this causes problems while edebugging edebug.
566 (let ((edebug-all-forms t) 567 (let ((edebug-all-forms t)
567 (edebug-all-defs t)) 568 (edebug-all-defs t))
568 (edebug-read-top-level-form)))) 569 (eval-sexp-add-defvars
570 (edebug-read-top-level-form)))))
569 571
570 572
571(defun edebug-read-top-level-form () 573(defun edebug-read-top-level-form ()
@@ -2462,6 +2464,7 @@ MSG is printed after `::::} '."
2462 (if edebug-global-break-condition 2464 (if edebug-global-break-condition
2463 (condition-case nil 2465 (condition-case nil
2464 (setq edebug-global-break-result 2466 (setq edebug-global-break-result
2467 ;; FIXME: lexbind.
2465 (eval edebug-global-break-condition)) 2468 (eval edebug-global-break-condition))
2466 (error nil)))) 2469 (error nil))))
2467 (edebug-break)) 2470 (edebug-break))
@@ -2473,6 +2476,7 @@ MSG is printed after `::::} '."
2473 (and edebug-break-data 2476 (and edebug-break-data
2474 (or (not edebug-break-condition) 2477 (or (not edebug-break-condition)
2475 (setq edebug-break-result 2478 (setq edebug-break-result
2479 ;; FIXME: lexbind.
2476 (eval edebug-break-condition)))))) 2480 (eval edebug-break-condition))))))
2477 (if (and edebug-break 2481 (if (and edebug-break
2478 (nth 2 edebug-break-data)) ; is it temporary? 2482 (nth 2 edebug-break-data)) ; is it temporary?
@@ -3633,9 +3637,10 @@ Return the result of the last expression."
3633 3637
3634(defun edebug-eval (edebug-expr) 3638(defun edebug-eval (edebug-expr)
3635 ;; Are there cl lexical variables active? 3639 ;; Are there cl lexical variables active?
3636 (if (bound-and-true-p cl-debug-env) 3640 (eval (if (bound-and-true-p cl-debug-env)
3637 (eval (cl-macroexpand-all edebug-expr cl-debug-env)) 3641 (cl-macroexpand-all edebug-expr cl-debug-env)
3638 (eval edebug-expr))) 3642 edebug-expr)
3643 lexical-binding))
3639 3644
3640(defun edebug-safe-eval (edebug-expr) 3645(defun edebug-safe-eval (edebug-expr)
3641 ;; Evaluate EXPR safely. 3646 ;; Evaluate EXPR safely.
@@ -4237,8 +4242,8 @@ It is removed when you hit any char."
4237;;; Menus 4242;;; Menus
4238 4243
4239(defun edebug-toggle (variable) 4244(defun edebug-toggle (variable)
4240 (set variable (not (eval variable))) 4245 (set variable (not (symbol-value variable)))
4241 (message "%s: %s" variable (eval variable))) 4246 (message "%s: %s" variable (symbol-value variable)))
4242 4247
4243;; We have to require easymenu (even for Emacs 18) just so 4248;; We have to require easymenu (even for Emacs 18) just so
4244;; the easy-menu-define macro call is compiled correctly. 4249;; the easy-menu-define macro call is compiled correctly.
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el
deleted file mode 100644
index ed6fb6f1c41..00000000000
--- a/lisp/emacs-lisp/eieio-comp.el
+++ /dev/null
@@ -1,142 +0,0 @@
1;;; eieio-comp.el -- eieio routines to help with byte compilation
2
3;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011
4;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Version: 0.2
8;; Keywords: lisp, tools
9;; Package: eieio
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; Byte compiler functions for defmethod. This will affect the new GNU
29;; byte compiler for Emacs 19 and better. This function will be called by
30;; the byte compiler whenever a `defmethod' is encountered in a file.
31;; It will output a function call to `eieio-defmethod' with the byte
32;; compiled function as a parameter.
33
34;;; Code:
35
36(declare-function eieio-defgeneric-form "eieio" (method doc-string))
37
38;; Some compatibility stuff
39(eval-and-compile
40 (if (not (fboundp 'byte-compile-compiled-obj-to-list))
41 (defun byte-compile-compiled-obj-to-list (moose) nil))
42
43 (if (not (boundp 'byte-compile-outbuffer))
44 (defvar byte-compile-outbuffer nil))
45 )
46
47;; This teaches the byte compiler how to do this sort of thing.
48(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
49
50(defun byte-compile-file-form-defmethod (form)
51 "Mumble about the method we are compiling.
52This function is mostly ripped from `byte-compile-file-form-defun',
53but it's been modified to handle the special syntax of the `defmethod'
54command. There should probably be one for `defgeneric' as well, but
55that is called but rarely. Argument FORM is the body of the method."
56 (setq form (cdr form))
57 (let* ((meth (car form))
58 (key (progn (setq form (cdr form))
59 (cond ((or (eq ':BEFORE (car form))
60 (eq ':before (car form)))
61 (setq form (cdr form))
62 ":before ")
63 ((or (eq ':AFTER (car form))
64 (eq ':after (car form)))
65 (setq form (cdr form))
66 ":after ")
67 ((or (eq ':PRIMARY (car form))
68 (eq ':primary (car form)))
69 (setq form (cdr form))
70 ":primary ")
71 ((or (eq ':STATIC (car form))
72 (eq ':static (car form)))
73 (setq form (cdr form))
74 ":static ")
75 (t ""))))
76 (params (car form))
77 (lamparams (byte-compile-defmethod-param-convert params))
78 (arg1 (car params))
79 (class (if (listp arg1) (nth 1 arg1) nil))
80 (my-outbuffer (if (eval-when-compile (featurep 'xemacs))
81 byte-compile-outbuffer
82 (cond ((boundp 'bytecomp-outbuffer)
83 bytecomp-outbuffer) ; Emacs >= 23.2
84 ((boundp 'outbuffer) outbuffer)
85 (t (error "Unable to set outbuffer"))))))
86 (let ((name (format "%s::%s" (or class "#<generic>") meth)))
87 (if byte-compile-verbose
88 ;; #### filename used free
89 (message "Compiling %s... (%s)"
90 (cond ((boundp 'bytecomp-filename) bytecomp-filename)
91 ((boundp 'filename) filename)
92 (t ""))
93 name))
94 (setq byte-compile-current-form name) ; for warnings
95 )
96 ;; Flush any pending output
97 (byte-compile-flush-pending)
98 ;; Byte compile the body. For the byte compiled forms, add the
99 ;; rest arguments, which will get ignored by the engine which will
100 ;; add them later (I hope)
101 (let* ((new-one (byte-compile-lambda
102 (append (list 'lambda lamparams)
103 (cdr form))))
104 (code (byte-compile-byte-code-maker new-one)))
105 (princ "\n(eieio-defmethod '" my-outbuffer)
106 (princ meth my-outbuffer)
107 (princ " '(" my-outbuffer)
108 (princ key my-outbuffer)
109 (prin1 params my-outbuffer)
110 (princ " " my-outbuffer)
111 (prin1 code my-outbuffer)
112 (princ "))" my-outbuffer)
113 )
114 ;; Now add this function to the list of known functions.
115 ;; Don't bother with a doc string. Not relevant here.
116 (add-to-list 'byte-compile-function-environment
117 (cons meth
118 (eieio-defgeneric-form meth "")))
119
120 ;; Remove it from the undefined list if it is there.
121 (let ((elt (assq meth byte-compile-unresolved-functions)))
122 (if elt (setq byte-compile-unresolved-functions
123 (delq elt byte-compile-unresolved-functions))))
124
125 ;; nil prevents cruft from appearing in the output buffer.
126 nil))
127
128(defun byte-compile-defmethod-param-convert (paramlist)
129 "Convert method params into the params used by the `defmethod' thingy.
130Argument PARAMLIST is the parameter list to convert."
131 (let ((argfix nil))
132 (while paramlist
133 (setq argfix (cons (if (listp (car paramlist))
134 (car (car paramlist))
135 (car paramlist))
136 argfix))
137 (setq paramlist (cdr paramlist)))
138 (nreverse argfix)))
139
140(provide 'eieio-comp)
141
142;;; eieio-comp.el ends here
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 2fe33dfce2e..7a119e6bbc0 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -45,8 +45,7 @@
45;;; Code: 45;;; Code:
46 46
47(eval-when-compile 47(eval-when-compile
48 (require 'cl) 48 (require 'cl))
49 (require 'eieio-comp))
50 49
51(defvar eieio-version "1.3" 50(defvar eieio-version "1.3"
52 "Current version of EIEIO.") 51 "Current version of EIEIO.")
@@ -97,6 +96,7 @@ default setting for optimization purposes.")
97 "Non-nil means to optimize the method dispatch on primary methods.") 96 "Non-nil means to optimize the method dispatch on primary methods.")
98 97
99;; State Variables 98;; State Variables
99;; FIXME: These two constants below should have an `eieio-' prefix added!!
100(defvar this nil 100(defvar this nil
101 "Inside a method, this variable is the object in question. 101 "Inside a method, this variable is the object in question.
102DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. 102DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots.
@@ -123,6 +123,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!")
123;; while it is being built itself. 123;; while it is being built itself.
124(defvar eieio-default-superclass nil) 124(defvar eieio-default-superclass nil)
125 125
126;; FIXME: The constants below should have an `eieio-' prefix added!!
126(defconst class-symbol 1 "Class's symbol (self-referencing.).") 127(defconst class-symbol 1 "Class's symbol (self-referencing.).")
127(defconst class-parent 2 "Class parent slot.") 128(defconst class-parent 2 "Class parent slot.")
128(defconst class-children 3 "Class children class slot.") 129(defconst class-children 3 "Class children class slot.")
@@ -181,10 +182,6 @@ Stored outright without modifications or stripping.")
181 (t key) ;; already generic.. maybe. 182 (t key) ;; already generic.. maybe.
182 )) 183 ))
183 184
184;; How to specialty compile stuff.
185(autoload 'byte-compile-file-form-defmethod "eieio-comp"
186 "This function is used to byte compile methods in a nice way.")
187(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
188 185
189;;; Important macros used in eieio. 186;;; Important macros used in eieio.
190;; 187;;
@@ -1192,10 +1189,8 @@ IMPL is the symbol holding the method implementation."
1192 ;; is faster to execute this for not byte-compiled. ie, install this, 1189 ;; is faster to execute this for not byte-compiled. ie, install this,
1193 ;; then measure calls going through here. I wonder why. 1190 ;; then measure calls going through here. I wonder why.
1194 (require 'bytecomp) 1191 (require 'bytecomp)
1195 (let ((byte-compile-free-references nil) 1192 (let ((byte-compile-warnings nil))
1196 (byte-compile-warnings nil) 1193 (byte-compile
1197 )
1198 (byte-compile-lambda
1199 `(lambda (&rest local-args) 1194 `(lambda (&rest local-args)
1200 ,doc-string 1195 ,doc-string
1201 ;; This is a cool cheat. Usually we need to look up in the 1196 ;; This is a cool cheat. Usually we need to look up in the
@@ -1205,7 +1200,8 @@ IMPL is the symbol holding the method implementation."
1205 ;; of that one implementation, then clearly, there is no method def. 1200 ;; of that one implementation, then clearly, there is no method def.
1206 (if (not (eieio-object-p (car local-args))) 1201 (if (not (eieio-object-p (car local-args)))
1207 ;; Not an object. Just signal. 1202 ;; Not an object. Just signal.
1208 (signal 'no-method-definition (list ,(list 'quote method) local-args)) 1203 (signal 'no-method-definition
1204 (list ,(list 'quote method) local-args))
1209 1205
1210 ;; We do have an object. Make sure it is the right type. 1206 ;; We do have an object. Make sure it is the right type.
1211 (if ,(if (eq class eieio-default-superclass) 1207 (if ,(if (eq class eieio-default-superclass)
@@ -1228,9 +1224,7 @@ IMPL is the symbol holding the method implementation."
1228 ) 1224 )
1229 (apply ,(list 'quote impl) local-args) 1225 (apply ,(list 'quote impl) local-args)
1230 ;(,impl local-args) 1226 ;(,impl local-args)
1231 )))) 1227 )))))))
1232 )
1233 ))
1234 1228
1235(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) 1229(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
1236 "Setup METHOD to call the generic form." 1230 "Setup METHOD to call the generic form."
@@ -1296,9 +1290,35 @@ Summary:
1296 ((typearg class-name) arg2 &optional opt &rest rest) 1290 ((typearg class-name) arg2 &optional opt &rest rest)
1297 \"doc-string\" 1291 \"doc-string\"
1298 body)" 1292 body)"
1299 `(eieio-defmethod (quote ,method) (quote ,args))) 1293 (let* ((key (cond ((or (eq ':BEFORE (car args))
1300 1294 (eq ':before (car args)))
1301(defun eieio-defmethod (method args) 1295 (setq args (cdr args))
1296 :before)
1297 ((or (eq ':AFTER (car args))
1298 (eq ':after (car args)))
1299 (setq args (cdr args))
1300 :after)
1301 ((or (eq ':PRIMARY (car args))
1302 (eq ':primary (car args)))
1303 (setq args (cdr args))
1304 :primary)
1305 ((or (eq ':STATIC (car args))
1306 (eq ':static (car args)))
1307 (setq args (cdr args))
1308 :static)
1309 (t nil)))
1310 (params (car args))
1311 (lamparams
1312 (mapcar (lambda (param) (if (listp param) (car param) param))
1313 params))
1314 (arg1 (car params))
1315 (class (if (listp arg1) (nth 1 arg1) nil)))
1316 `(eieio-defmethod ',method
1317 '(,@(if key (list key))
1318 ,params)
1319 (lambda ,lamparams ,@(cdr args)))))
1320
1321(defun eieio-defmethod (method args &optional code)
1302 "Work part of the `defmethod' macro defining METHOD with ARGS." 1322 "Work part of the `defmethod' macro defining METHOD with ARGS."
1303 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) 1323 (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
1304 ;; find optional keys 1324 ;; find optional keys
@@ -1352,10 +1372,7 @@ Summary:
1352 ;; generics are higher 1372 ;; generics are higher
1353 (setq key (eieio-specialized-key-to-generic-key key))) 1373 (setq key (eieio-specialized-key-to-generic-key key)))
1354 ;; Put this lambda into the symbol so we can find it 1374 ;; Put this lambda into the symbol so we can find it
1355 (if (byte-code-function-p (car-safe body)) 1375 (eieiomt-add method code key argclass)
1356 (eieiomt-add method (car-safe body) key argclass)
1357 (eieiomt-add method (append (list 'lambda (reverse argfix)) body)
1358 key argclass))
1359 ) 1376 )
1360 1377
1361 (when eieio-optimize-primary-methods-flag 1378 (when eieio-optimize-primary-methods-flag
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index ceb1eb3bafb..7e40fdad352 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -28,7 +28,13 @@
28;; Provide an easy hook to tell if we are running with floats or not. 28;; Provide an easy hook to tell if we are running with floats or not.
29;; Define pi and e via math-lib calls (much less prone to killer typos). 29;; Define pi and e via math-lib calls (much less prone to killer typos).
30(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") 30(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
31(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.") 31(progn
32 ;; Simulate a defconst that doesn't declare the variable dynamically bound.
33 (setq-default pi float-pi)
34 (put 'pi 'variable-documentation
35 "Obsolete since Emacs-23.3. Use `float-pi' instead.")
36 (put 'pi 'risky-local-variable t)
37 (push 'pi current-load-list))
32 38
33(defconst float-e (exp 1) "The value of e (2.7182818...).") 39(defconst float-e (exp 1) "The value of e (2.7182818...).")
34 40
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 15690023700..39bdb505039 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -699,7 +699,9 @@ If CHAR is not a character, return nil."
699 "Evaluate sexp before point; print value in minibuffer. 699 "Evaluate sexp before point; print value in minibuffer.
700With argument, print output into current buffer." 700With argument, print output into current buffer."
701 (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) 701 (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)))
702 (eval-last-sexp-print-value (eval (preceding-sexp))))) 702 ;; Setup the lexical environment if lexical-binding is enabled.
703 (eval-last-sexp-print-value
704 (eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding))))
703 705
704 706
705(defun eval-last-sexp-print-value (value) 707(defun eval-last-sexp-print-value (value)
@@ -727,6 +729,23 @@ With argument, print output into current buffer."
727 729
728(defvar eval-last-sexp-fake-value (make-symbol "t")) 730(defvar eval-last-sexp-fake-value (make-symbol "t"))
729 731
732(defun eval-sexp-add-defvars (exp &optional pos)
733 "Prepend EXP with all the `defvar's that precede it in the buffer.
734POS specifies the starting position where EXP was found and defaults to point."
735 (if (not lexical-binding)
736 exp
737 (save-excursion
738 (unless pos (setq pos (point)))
739 (let ((vars ()))
740 (goto-char (point-min))
741 (while (re-search-forward
742 "^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
743 pos t)
744 (let ((var (intern (match-string 1))))
745 (unless (special-variable-p var)
746 (push var vars))))
747 `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
748
730(defun eval-last-sexp (eval-last-sexp-arg-internal) 749(defun eval-last-sexp (eval-last-sexp-arg-internal)
731 "Evaluate sexp before point; print value in minibuffer. 750 "Evaluate sexp before point; print value in minibuffer.
732Interactively, with prefix argument, print output into current buffer. 751Interactively, with prefix argument, print output into current buffer.
@@ -763,16 +782,18 @@ Reinitialize the face according to the `defface' specification."
763 ;; `defcustom' is now macroexpanded to 782 ;; `defcustom' is now macroexpanded to
764 ;; `custom-declare-variable' with a quoted value arg. 783 ;; `custom-declare-variable' with a quoted value arg.
765 ((and (eq (car form) 'custom-declare-variable) 784 ((and (eq (car form) 'custom-declare-variable)
766 (default-boundp (eval (nth 1 form)))) 785 (default-boundp (eval (nth 1 form) lexical-binding)))
767 ;; Force variable to be bound. 786 ;; Force variable to be bound.
768 (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) 787 (set-default (eval (nth 1 form) lexical-binding)
788 (eval (nth 1 (nth 2 form)) lexical-binding))
769 form) 789 form)
770 ;; `defface' is macroexpanded to `custom-declare-face'. 790 ;; `defface' is macroexpanded to `custom-declare-face'.
771 ((eq (car form) 'custom-declare-face) 791 ((eq (car form) 'custom-declare-face)
772 ;; Reset the face. 792 ;; Reset the face.
773 (setq face-new-frame-defaults 793 (setq face-new-frame-defaults
774 (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) 794 (assq-delete-all (eval (nth 1 form) lexical-binding)
775 (put (eval (nth 1 form)) 'face-defface-spec nil) 795 face-new-frame-defaults))
796 (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil)
776 ;; Setting `customized-face' to the new spec after calling 797 ;; Setting `customized-face' to the new spec after calling
777 ;; the form, but preserving the old saved spec in `saved-face', 798 ;; the form, but preserving the old saved spec in `saved-face',
778 ;; imitates the situation when the new face spec is set 799 ;; imitates the situation when the new face spec is set
@@ -783,10 +804,11 @@ Reinitialize the face according to the `defface' specification."
783 ;; `defface' change the spec, regardless of a saved spec. 804 ;; `defface' change the spec, regardless of a saved spec.
784 (prog1 `(prog1 ,form 805 (prog1 `(prog1 ,form
785 (put ,(nth 1 form) 'saved-face 806 (put ,(nth 1 form) 'saved-face
786 ',(get (eval (nth 1 form)) 'saved-face)) 807 ',(get (eval (nth 1 form) lexical-binding)
808 'saved-face))
787 (put ,(nth 1 form) 'customized-face 809 (put ,(nth 1 form) 'customized-face
788 ,(nth 2 form))) 810 ,(nth 2 form)))
789 (put (eval (nth 1 form)) 'saved-face nil))) 811 (put (eval (nth 1 form) lexical-binding) 'saved-face nil)))
790 ((eq (car form) 'progn) 812 ((eq (car form) 'progn)
791 (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) 813 (cons 'progn (mapcar 'eval-defun-1 (cdr form))))
792 (t form))) 814 (t form)))
@@ -1205,7 +1227,6 @@ This function also returns nil meaning don't specify the indentation."
1205(put 'prog1 'lisp-indent-function 1) 1227(put 'prog1 'lisp-indent-function 1)
1206(put 'prog2 'lisp-indent-function 2) 1228(put 'prog2 'lisp-indent-function 2)
1207(put 'save-excursion 'lisp-indent-function 0) 1229(put 'save-excursion 'lisp-indent-function 0)
1208(put 'save-window-excursion 'lisp-indent-function 0)
1209(put 'save-restriction 'lisp-indent-function 0) 1230(put 'save-restriction 'lisp-indent-function 0)
1210(put 'save-match-data 'lisp-indent-function 0) 1231(put 'save-match-data 'lisp-indent-function 0)
1211(put 'save-current-buffer 'lisp-indent-function 0) 1232(put 'save-current-buffer 'lisp-indent-function 0)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index af8047256e2..f0a075ace37 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -1,4 +1,4 @@
1;;; macroexp.el --- Additional macro-expansion support 1;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
2;; 2;;
3;; Copyright (C) 2004-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
4;; 4;;
@@ -29,6 +29,8 @@
29 29
30;;; Code: 30;;; Code:
31 31
32(eval-when-compile (require 'cl))
33
32;; Bound by the top-level `macroexpand-all', and modified to include any 34;; Bound by the top-level `macroexpand-all', and modified to include any
33;; macros defined by `defmacro'. 35;; macros defined by `defmacro'.
34(defvar macroexpand-all-environment nil) 36(defvar macroexpand-all-environment nil)
@@ -106,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
106 (macroexpand (macroexpand-all-forms form 1) 108 (macroexpand (macroexpand-all-forms form 1)
107 macroexpand-all-environment) 109 macroexpand-all-environment)
108 ;; Normal form; get its expansion, and then expand arguments. 110 ;; Normal form; get its expansion, and then expand arguments.
109 (setq form (macroexpand form macroexpand-all-environment)) 111 (let ((new-form (macroexpand form macroexpand-all-environment)))
112 (when (and (not (eq form new-form)) ;It was a macro call.
113 (car-safe form)
114 (symbolp (car form))
115 (get (car form) 'byte-obsolete-info)
116 (fboundp 'byte-compile-warn-obsolete))
117 (byte-compile-warn-obsolete (car form)))
118 (setq form new-form))
110 (pcase form 119 (pcase form
111 (`(cond . ,clauses) 120 (`(cond . ,clauses)
112 (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) 121 (maybe-cons 'cond (macroexpand-all-clauses clauses) form))
@@ -122,7 +131,16 @@ Assumes the caller has bound `macroexpand-all-environment'."
122 (`(defmacro ,name . ,args-and-body) 131 (`(defmacro ,name . ,args-and-body)
123 (push (cons name (cons 'lambda args-and-body)) 132 (push (cons name (cons 'lambda args-and-body))
124 macroexpand-all-environment) 133 macroexpand-all-environment)
125 (macroexpand-all-forms form 3)) 134 (let ((n 3))
135 ;; Don't macroexpand `declare' since it should really be "expanded"
136 ;; away when `defmacro' is expanded, but currently defmacro is not
137 ;; itself a macro. So both `defmacro' and `declare' need to be
138 ;; handled directly in bytecomp.el.
139 ;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote).
140 (while (or (stringp (nth n form))
141 (eq (car-safe (nth n form)) 'declare))
142 (setq n (1+ n)))
143 (macroexpand-all-forms form n)))
126 (`(defun . ,_) (macroexpand-all-forms form 3)) 144 (`(defun . ,_) (macroexpand-all-forms form 3))
127 (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) 145 (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2))
128 (`(function ,(and f `(lambda . ,_))) 146 (`(function ,(and f `(lambda . ,_)))
@@ -151,19 +169,34 @@ Assumes the caller has bound `macroexpand-all-environment'."
151 ;; here, so that any code that cares about the difference will 169 ;; here, so that any code that cares about the difference will
152 ;; see the same transformation. 170 ;; see the same transformation.
153 ;; First arg is a function: 171 ;; First arg is a function:
154 (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) 172 (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc))
173 ',(and f `(lambda . ,_)) . ,args)
155 ;; We don't use `maybe-cons' since there's clearly a change. 174 ;; We don't use `maybe-cons' since there's clearly a change.
156 (cons fun 175 (cons fun
157 (cons (macroexpand-all-1 (list 'function f)) 176 (cons (macroexpand-all-1 (list 'function f))
158 (macroexpand-all-forms args)))) 177 (macroexpand-all-forms args))))
159 ;; Second arg is a function: 178 ;; Second arg is a function:
160 (`(,(and fun (or `sort)) ,arg1 ',f . ,args) 179 (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
161 ;; We don't use `maybe-cons' since there's clearly a change. 180 ;; We don't use `maybe-cons' since there's clearly a change.
162 (cons fun 181 (cons fun
163 (cons (macroexpand-all-1 arg1) 182 (cons (macroexpand-all-1 arg1)
164 (cons (macroexpand-all-1 183 (cons (macroexpand-all-1
165 (list 'function f)) 184 (list 'function f))
166 (macroexpand-all-forms args))))) 185 (macroexpand-all-forms args)))))
186 ;; Macro expand compiler macros. This cannot be delayed to
187 ;; byte-optimize-form because the output of the compiler-macro can
188 ;; use macros.
189 ;; FIXME: Don't depend on CL.
190 (`(,(pred (lambda (fun)
191 (and (symbolp fun)
192 (eq (get fun 'byte-compile)
193 'cl-byte-compile-compiler-macro)
194 (functionp 'compiler-macroexpand))))
195 . ,_)
196 (let ((newform (with-no-warnings (compiler-macroexpand form))))
197 (if (eq form newform)
198 (macroexpand-all-forms form 1)
199 (macroexpand-all-1 newform))))
167 (`(,_ . ,_) 200 (`(,_ . ,_)
168 ;; For every other list, we just expand each argument (for 201 ;; For every other list, we just expand each argument (for
169 ;; setq/setq-default this works alright because the variable names 202 ;; setq/setq-default this works alright because the variable names
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 916dcd4785c..e6c4ccbbc50 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -1,4 +1,4 @@
1;;; pcase.el --- ML-style pattern-matching macro for Elisp 1;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2010-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
4 4
@@ -27,16 +27,21 @@
27 27
28;; Todo: 28;; Todo:
29 29
30;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
31;; use x, because x is bound separately for the equality constraint
32;; (as well as any pred/guard) and for the body, so uses at one place don't
33;; count for the other.
30;; - provide ways to extend the set of primitives, with some kind of 34;; - provide ways to extend the set of primitives, with some kind of
31;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) 35;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
32;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). 36;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
33;; But better would be if we could define new ways to match by having the 37;; But better would be if we could define new ways to match by having the
34;; extension provide its own `pcase--split-<foo>' thingy. 38;; extension provide its own `pcase--split-<foo>' thingy.
39;; - along these lines, provide patterns to match CL structs.
35;; - provide something like (setq VAR) so a var can be set rather than 40;; - provide something like (setq VAR) so a var can be set rather than
36;; let-bound. 41;; let-bound.
37;; - provide a way to fallthrough to other cases. 42;; - provide a way to fallthrough to subsequent cases.
38;; - try and be more clever to reduce the size of the decision tree, and 43;; - try and be more clever to reduce the size of the decision tree, and
39;; to reduce the number of leafs that need to be turned into function: 44;; to reduce the number of leaves that need to be turned into function:
40;; - first, do the tests shared by all remaining branches (it will have 45;; - first, do the tests shared by all remaining branches (it will have
41;; to be performed anyway, so better so it first so it's shared). 46;; to be performed anyway, so better so it first so it's shared).
42;; - then choose the test that discriminates more (?). 47;; - then choose the test that discriminates more (?).
@@ -45,14 +50,12 @@
45 50
46;;; Code: 51;;; Code:
47 52
48(eval-when-compile (require 'cl))
49
50;; Macro-expansion of pcase is reasonably fast, so it's not a problem 53;; Macro-expansion of pcase is reasonably fast, so it's not a problem
51;; when byte-compiling a file, but when interpreting the code, if the pcase 54;; when byte-compiling a file, but when interpreting the code, if the pcase
52;; is in a loop, the repeated macro-expansion becomes terribly costly, so we 55;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
53;; memoize previous macro expansions to try and avoid recomputing them 56;; memoize previous macro expansions to try and avoid recomputing them
54;; over and over again. 57;; over and over again.
55(defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) 58(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
56 59
57(defconst pcase--dontcare-upats '(t _ dontcare)) 60(defconst pcase--dontcare-upats '(t _ dontcare))
58 61
@@ -69,6 +72,7 @@ UPatterns can take the following forms:
69 `QPAT matches if the QPattern QPAT matches. 72 `QPAT matches if the QPattern QPAT matches.
70 (pred PRED) matches if PRED applied to the object returns non-nil. 73 (pred PRED) matches if PRED applied to the object returns non-nil.
71 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. 74 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
75 (let UPAT EXP) matches if EXP matches UPAT.
72If a SYMBOL is used twice in the same pattern (i.e. the pattern is 76If a SYMBOL is used twice in the same pattern (i.e. the pattern is
73\"non-linear\"), then the second occurrence is turned into an `eq'uality test. 77\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
74 78
@@ -88,10 +92,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern
88like `(,a . ,(pred (< a))) or, with more checks: 92like `(,a . ,(pred (< a))) or, with more checks:
89`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" 93`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
90 (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. 94 (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
91 (or (gethash (cons exp cases) pcase-memoize) 95 ;; We want to use a weak hash table as a cache, but the key will unavoidably
92 (puthash (cons exp cases) 96 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
93 (pcase--expand exp cases) 97 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
94 pcase-memoize))) 98 ;; which does come straight from the source code and should hence not be GC'd
99 ;; so easily.
100 (let ((data (gethash (car cases) pcase--memoize)))
101 ;; data = (EXP CASES . EXPANSION)
102 (if (and (equal exp (car data)) (equal cases (cadr data)))
103 ;; We have the right expansion.
104 (cddr data)
105 (when data
106 (message "pcase-memoize: equal first branch, yet different"))
107 (let ((expansion (pcase--expand exp cases)))
108 (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
109 expansion))))
95 110
96;;;###autoload 111;;;###autoload
97(defmacro pcase-let* (bindings &rest body) 112(defmacro pcase-let* (bindings &rest body)
@@ -145,6 +160,8 @@ of the form (UPAT EXP)."
145 (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) 160 (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
146 161
147(defun pcase--expand (exp cases) 162(defun pcase--expand (exp cases)
163 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
164 ;; (emacs-pid) exp (sxhash cases))
148 (let* ((defs (if (symbolp exp) '() 165 (let* ((defs (if (symbolp exp) '()
149 (let ((sym (make-symbol "x"))) 166 (let ((sym (make-symbol "x")))
150 (prog1 `((,sym ,exp)) (setq exp sym))))) 167 (prog1 `((,sym ,exp)) (setq exp sym)))))
@@ -165,7 +182,9 @@ of the form (UPAT EXP)."
165 ;; to a separate function if that number is too high. 182 ;; to a separate function if that number is too high.
166 ;; 183 ;;
167 ;; We've already used this branch. So it is shared. 184 ;; We've already used this branch. So it is shared.
168 (destructuring-bind (code prevvars res) prev 185 (let* ((code (car prev)) (cdrprev (cdr prev))
186 (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
187 (res (car cddrprev)))
169 (unless (symbolp res) 188 (unless (symbolp res)
170 ;; This is the first repeat, so we have to move 189 ;; This is the first repeat, so we have to move
171 ;; the branch to a separate function. 190 ;; the branch to a separate function.
@@ -269,7 +288,10 @@ MATCH is the pattern that needs to be matched, of the form:
269 (and MATCH ...) 288 (and MATCH ...)
270 (or MATCH ...)" 289 (or MATCH ...)"
271 (when (setq branches (delq nil branches)) 290 (when (setq branches (delq nil branches))
272 (destructuring-bind (match code &rest vars) (car branches) 291 (let* ((carbranch (car branches))
292 (match (car carbranch)) (cdarbranch (cdr carbranch))
293 (code (car cdarbranch))
294 (vars (cdr cdarbranch)))
273 (pcase--u1 (list match) code vars (cdr branches))))) 295 (pcase--u1 (list match) code vars (cdr branches)))))
274 296
275(defun pcase--and (match matches) 297(defun pcase--and (match matches)
@@ -281,19 +303,25 @@ MATCH is the pattern that needs to be matched, of the form:
281 (symbolp . consp) 303 (symbolp . consp)
282 (symbolp . arrayp) 304 (symbolp . arrayp)
283 (symbolp . stringp) 305 (symbolp . stringp)
306 (symbolp . byte-code-function-p)
284 (integerp . consp) 307 (integerp . consp)
285 (integerp . arrayp) 308 (integerp . arrayp)
286 (integerp . stringp) 309 (integerp . stringp)
310 (integerp . byte-code-function-p)
287 (numberp . consp) 311 (numberp . consp)
288 (numberp . arrayp) 312 (numberp . arrayp)
289 (numberp . stringp) 313 (numberp . stringp)
314 (numberp . byte-code-function-p)
290 (consp . arrayp) 315 (consp . arrayp)
291 (consp . stringp) 316 (consp . stringp)
292 (arrayp . stringp))) 317 (consp . byte-code-function-p)
318 (arrayp . stringp)
319 (arrayp . byte-code-function-p)
320 (stringp . byte-code-function-p)))
293 321
294(defun pcase--split-match (sym splitter match) 322(defun pcase--split-match (sym splitter match)
295 (case (car match) 323 (cond
296 ((match) 324 ((eq (car match) 'match)
297 (if (not (eq sym (cadr match))) 325 (if (not (eq sym (cadr match)))
298 (cons match match) 326 (cons match match)
299 (let ((pat (cddr match))) 327 (let ((pat (cddr match)))
@@ -307,7 +335,7 @@ MATCH is the pattern that needs to be matched, of the form:
307 (cdr pat))))) 335 (cdr pat)))))
308 (t (let ((res (funcall splitter (cddr match)))) 336 (t (let ((res (funcall splitter (cddr match))))
309 (cons (or (car res) match) (or (cdr res) match)))))))) 337 (cons (or (car res) match) (or (cdr res) match))))))))
310 ((or and) 338 ((memq (car match) '(or and))
311 (let ((then-alts '()) 339 (let ((then-alts '())
312 (else-alts '()) 340 (else-alts '())
313 (neutral-elem (if (eq 'or (car match)) 341 (neutral-elem (if (eq 'or (car match))
@@ -474,53 +502,60 @@ Otherwise, it defers to REST which is a list of branches of the form
474 (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) 502 (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
475 code vars 503 code vars
476 (if (null others) rest 504 (if (null others) rest
477 (cons (list* 505 (cons (cons
478 (pcase--and (if (cdr others) 506 (pcase--and (if (cdr others)
479 (cons 'or (nreverse others)) 507 (cons 'or (nreverse others))
480 (car others)) 508 (car others))
481 (cdr matches)) 509 (cdr matches))
482 code vars) 510 (cons code vars))
483 rest)))) 511 rest))))
484 (t 512 (t
485 (pcase--u1 (cons (pop alts) (cdr matches)) code vars 513 (pcase--u1 (cons (pop alts) (cdr matches)) code vars
486 (if (null alts) (progn (error "Please avoid it") rest) 514 (if (null alts) (progn (error "Please avoid it") rest)
487 (cons (list* 515 (cons (cons
488 (pcase--and (if (cdr alts) 516 (pcase--and (if (cdr alts)
489 (cons 'or alts) (car alts)) 517 (cons 'or alts) (car alts))
490 (cdr matches)) 518 (cdr matches))
491 code vars) 519 (cons code vars))
492 rest))))))) 520 rest)))))))
493 ((eq 'match (caar matches)) 521 ((eq 'match (caar matches))
494 (destructuring-bind (op sym &rest upat) (pop matches) 522 (let* ((popmatches (pop matches))
523 (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
524 (sym (car cdrpopmatches))
525 (upat (cdr cdrpopmatches)))
495 (cond 526 (cond
496 ((memq upat '(t _)) (pcase--u1 matches code vars rest)) 527 ((memq upat '(t _)) (pcase--u1 matches code vars rest))
497 ((eq upat 'dontcare) :pcase--dontcare) 528 ((eq upat 'dontcare) :pcase--dontcare)
498 ((functionp upat) (error "Feature removed, use (pred %s)" upat))
499 ((memq (car-safe upat) '(guard pred)) 529 ((memq (car-safe upat) '(guard pred))
500 (if (eq (car upat) 'pred) (put sym 'pcase-used t)) 530 (if (eq (car upat) 'pred) (put sym 'pcase-used t))
501 (destructuring-bind (then-rest &rest else-rest) 531 (let* ((splitrest
502 (pcase--split-rest 532 (pcase--split-rest
503 sym (apply-partially #'pcase--split-pred upat) rest) 533 sym (apply-partially #'pcase--split-pred upat) rest))
534 (then-rest (car splitrest))
535 (else-rest (cdr splitrest)))
504 (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) 536 (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
505 `(,(cadr upat) ,sym) 537 `(,(cadr upat) ,sym)
506 (let* ((exp (cadr upat)) 538 (let* ((exp (cadr upat))
507 ;; `vs' is an upper bound on the vars we need. 539 ;; `vs' is an upper bound on the vars we need.
508 (vs (pcase--fgrep (mapcar #'car vars) exp)) 540 (vs (pcase--fgrep (mapcar #'car vars) exp))
509 (call (cond 541 (env (mapcar (lambda (var)
510 ((eq 'guard (car upat)) exp) 542 (list var (cdr (assq var vars))))
511 ((functionp exp) `(,exp ,sym)) 543 vs))
512 (t `(,@exp ,sym))))) 544 (call (if (eq 'guard (car upat))
545 exp
546 (when (memq sym vs)
547 ;; `sym' is shadowed by `env'.
548 (let ((newsym (make-symbol "x")))
549 (push (list newsym sym) env)
550 (setq sym newsym)))
551 (if (functionp exp) `(,exp ,sym)
552 `(,@exp ,sym)))))
513 (if (null vs) 553 (if (null vs)
514 call 554 call
515 ;; Let's not replace `vars' in `exp' since it's 555 ;; Let's not replace `vars' in `exp' since it's
516 ;; too difficult to do it right, instead just 556 ;; too difficult to do it right, instead just
517 ;; let-bind `vars' around `exp'. 557 ;; let-bind `vars' around `exp'.
518 `(let ,(mapcar (lambda (var) 558 `(let* ,env ,call))))
519 (list var (cdr (assq var vars))))
520 vs)
521 ;; FIXME: `vars' can capture `sym'. E.g.
522 ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
523 ,call))))
524 (pcase--u1 matches code vars then-rest) 559 (pcase--u1 matches code vars then-rest)
525 (pcase--u else-rest)))) 560 (pcase--u else-rest))))
526 ((symbolp upat) 561 ((symbolp upat)
@@ -531,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form
531 (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) 566 (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
532 matches) 567 matches)
533 code vars rest))) 568 code vars rest)))
569 ((eq (car-safe upat) 'let)
570 ;; A upat of the form (let VAR EXP).
571 ;; (pcase--u1 matches code
572 ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
573 (let* ((exp
574 (let* ((exp (nth 2 upat))
575 (found (assq exp vars)))
576 (if found (cdr found)
577 (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
578 (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
579 vs)))
580 (if env `(let* ,env ,exp) exp)))))
581 (sym (if (symbolp exp) exp (make-symbol "x")))
582 (body
583 (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
584 code vars rest)))
585 (if (eq sym exp)
586 body
587 `(let* ((,sym ,exp)) ,body))))
534 ((eq (car-safe upat) '\`) 588 ((eq (car-safe upat) '\`)
535 (put sym 'pcase-used t) 589 (put sym 'pcase-used t)
536 (pcase--q1 sym (cadr upat) matches code vars rest)) 590 (pcase--q1 sym (cadr upat) matches code vars rest))
@@ -546,13 +600,15 @@ Otherwise, it defers to REST which is a list of branches of the form
546 (setq all nil)))) 600 (setq all nil))))
547 (if all 601 (if all
548 ;; Use memq for (or `a `b `c `d) rather than a big tree. 602 ;; Use memq for (or `a `b `c `d) rather than a big tree.
549 (let ((elems (mapcar 'cadr (cdr upat)))) 603 (let* ((elems (mapcar 'cadr (cdr upat)))
550 (destructuring-bind (then-rest &rest else-rest) 604 (splitrest
551 (pcase--split-rest 605 (pcase--split-rest
552 sym (apply-partially #'pcase--split-member elems) rest) 606 sym (apply-partially #'pcase--split-member elems) rest))
553 (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) 607 (then-rest (car splitrest))
554 (pcase--u1 matches code vars then-rest) 608 (else-rest (cdr splitrest)))
555 (pcase--u else-rest)))) 609 (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
610 (pcase--u1 matches code vars then-rest)
611 (pcase--u else-rest)))
556 (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars 612 (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
557 (append (mapcar (lambda (upat) 613 (append (mapcar (lambda (upat)
558 `((and (match ,sym . ,upat) ,@matches) 614 `((and (match ,sym . ,upat) ,@matches)
@@ -575,15 +631,14 @@ Otherwise, it defers to REST which is a list of branches of the form
575 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite 631 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
576 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). 632 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
577 (pcase--u1 `((match ,sym . ,(cadr upat))) 633 (pcase--u1 `((match ,sym . ,(cadr upat)))
578 (lexical-let ((rest rest)) 634 ;; FIXME: This codegen is not careful to share its
579 ;; FIXME: This codegen is not careful to share its 635 ;; code if used several times: code blow up is likely.
580 ;; code if used several times: code blow up is likely. 636 (lambda (_vars)
581 (lambda (vars) 637 ;; `vars' will likely contain bindings which are
582 ;; `vars' will likely contain bindings which are 638 ;; not always available in other paths to
583 ;; not always available in other paths to 639 ;; `rest', so there' no point trying to pass
584 ;; `rest', so there' no point trying to pass 640 ;; them down.
585 ;; them down. 641 (pcase--u rest))
586 (pcase--u rest)))
587 vars 642 vars
588 (list `((and . ,matches) ,code . ,vars)))) 643 (list `((and . ,matches) ,code . ,vars))))
589 (t (error "Unknown upattern `%s'" upat))))) 644 (t (error "Unknown upattern `%s'" upat)))))
@@ -600,29 +655,33 @@ Otherwise, it defers to REST which is a list of branches of the form
600 ;; FIXME. 655 ;; FIXME.
601 (error "Vector QPatterns not implemented yet")) 656 (error "Vector QPatterns not implemented yet"))
602 ((consp qpat) 657 ((consp qpat)
603 (let ((syma (make-symbol "xcar")) 658 (let* ((syma (make-symbol "xcar"))
604 (symd (make-symbol "xcdr"))) 659 (symd (make-symbol "xcdr"))
605 (destructuring-bind (then-rest &rest else-rest) 660 (splitrest (pcase--split-rest
606 (pcase--split-rest sym 661 sym
607 (apply-partially #'pcase--split-consp syma symd) 662 (apply-partially #'pcase--split-consp syma symd)
608 rest) 663 rest))
609 (let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) 664 (then-rest (car splitrest))
610 (match ,symd . ,(pcase--upat (cdr qpat))) 665 (else-rest (cdr splitrest))
611 ,@matches) 666 (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
612 code vars then-rest))) 667 (match ,symd . ,(pcase--upat (cdr qpat)))
613 (pcase--if 668 ,@matches)
614 `(consp ,sym) 669 code vars then-rest)))
615 ;; We want to be careful to only add bindings that are used. 670 (pcase--if
616 ;; The byte-compiler could do that for us, but it would have to pay 671 `(consp ,sym)
617 ;; attention to the `consp' test in order to figure out that car/cdr 672 ;; We want to be careful to only add bindings that are used.
618 ;; can't signal errors and our byte-compiler is not that clever. 673 ;; The byte-compiler could do that for us, but it would have to pay
619 `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) 674 ;; attention to the `consp' test in order to figure out that car/cdr
620 ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) 675 ;; can't signal errors and our byte-compiler is not that clever.
621 ,then-body) 676 `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
622 (pcase--u else-rest)))))) 677 ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
678 ,then-body)
679 (pcase--u else-rest))))
623 ((or (integerp qpat) (symbolp qpat) (stringp qpat)) 680 ((or (integerp qpat) (symbolp qpat) (stringp qpat))
624 (destructuring-bind (then-rest &rest else-rest) 681 (let* ((splitrest (pcase--split-rest
625 (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) 682 sym (apply-partially 'pcase--split-equal qpat) rest))
683 (then-rest (car splitrest))
684 (else-rest (cdr splitrest)))
626 (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) 685 (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
627 (pcase--u1 matches code vars then-rest) 686 (pcase--u1 matches code vars then-rest)
628 (pcase--u else-rest)))) 687 (pcase--u else-rest))))
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index e81a8b37981..2701d6b940b 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -1,4 +1,4 @@
1;;; smie.el --- Simple Minded Indentation Engine 1;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2010-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
4 4
@@ -178,7 +178,7 @@ one of those elements share the same precedence level and associativity."
178 ;; Maybe also add (or <elem1> <elem2>...) for things like 178 ;; Maybe also add (or <elem1> <elem2>...) for things like
179 ;; (exp (exp (or "+" "*" "=" ..) exp)). 179 ;; (exp (exp (or "+" "*" "=" ..) exp)).
180 ;; Basically, make it EBNF (except for the specification of a separator in 180 ;; Basically, make it EBNF (except for the specification of a separator in
181 ;; the repetition). 181 ;; the repetition, maybe).
182 (let ((nts (mapcar 'car bnf)) ;Non-terminals 182 (let ((nts (mapcar 'car bnf)) ;Non-terminals
183 (first-ops-table ()) 183 (first-ops-table ())
184 (last-ops-table ()) 184 (last-ops-table ())
diff --git a/lisp/files.el b/lisp/files.el
index 198d5ca87de..38047f2fa43 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -2869,18 +2869,19 @@ asking you for confirmation."
2869;; 2869;;
2870;; For variables defined in the C source code the declaration should go here: 2870;; For variables defined in the C source code the declaration should go here:
2871 2871
2872(mapc (lambda (pair) 2872(dolist (pair
2873 (put (car pair) 'safe-local-variable (cdr pair))) 2873 '((buffer-read-only . booleanp) ;; C source code
2874 '((buffer-read-only . booleanp) ;; C source code 2874 (default-directory . stringp) ;; C source code
2875 (default-directory . stringp) ;; C source code 2875 (fill-column . integerp) ;; C source code
2876 (fill-column . integerp) ;; C source code 2876 (indent-tabs-mode . booleanp) ;; C source code
2877 (indent-tabs-mode . booleanp) ;; C source code 2877 (left-margin . integerp) ;; C source code
2878 (left-margin . integerp) ;; C source code 2878 (no-update-autoloads . booleanp)
2879 (no-update-autoloads . booleanp) 2879 (lexical-binding . booleanp) ;; C source code
2880 (tab-width . integerp) ;; C source code 2880 (tab-width . integerp) ;; C source code
2881 (truncate-lines . booleanp) ;; C source code 2881 (truncate-lines . booleanp) ;; C source code
2882 (word-wrap . booleanp) ;; C source code 2882 (word-wrap . booleanp) ;; C source code
2883 (bidi-display-reordering . booleanp))) ;; C source code 2883 (bidi-display-reordering . booleanp))) ;; C source code
2884 (put (car pair) 'safe-local-variable (cdr pair)))
2884 2885
2885(put 'bidi-paragraph-direction 'safe-local-variable 2886(put 'bidi-paragraph-direction 'safe-local-variable
2886 (lambda (v) (memq v '(nil right-to-left left-to-right)))) 2887 (lambda (v) (memq v '(nil right-to-left left-to-right))))
diff --git a/lisp/follow.el b/lisp/follow.el
index 7e6d4e7ee35..7f4093dd442 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)"
871 ;; XEmacs can calculate the end of the window by using 871 ;; XEmacs can calculate the end of the window by using
872 ;; the 'guarantee options. GOOD! 872 ;; the 'guarantee options. GOOD!
873 (let ((end (window-end win t))) 873 (let ((end (window-end win t)))
874 (if (= end (funcall (symbol-function 'point-max) 874 (if (= end (point-max (window-buffer win)))
875 (window-buffer win)))
876 (list end t) 875 (list end t)
877 (list (+ end 1) nil))) 876 (list (+ end 1) nil)))
878 ;; Emacs: We have to calculate the end by ourselves. 877 ;; Emacs: We have to calculate the end by ourselves.
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 2496453dd89..37faf83fd12 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,8 @@
12011-04-01 Julien Danjou <julien@danjou.info>
2
3 * mm-view.el (mm-display-inline-fontify): Do not fontify with
4 fundamental-mode.
5
12011-03-30 Lars Magne Ingebrigtsen <larsi@gnus.org> 62011-03-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
2 7
3 * gnus-sum.el (gnus-update-marks): Revert intersection change, which 8 * gnus-sum.el (gnus-update-marks): Revert intersection change, which
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index abd78b8de02..5a90f015aed 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -608,7 +608,9 @@ If MODE is not set, try to find mode automatically."
608 (funcall mode) 608 (funcall mode)
609 (set-auto-mode)) 609 (set-auto-mode))
610 ;; The mode function might have already turned on font-lock. 610 ;; The mode function might have already turned on font-lock.
611 (unless (symbol-value 'font-lock-mode) 611 ;; Do not fontify if the guess mode is fundamental.
612 (unless (or (symbol-value 'font-lock-mode)
613 (eq major-mode 'fundamental-mode))
612 (font-lock-fontify-buffer))) 614 (font-lock-fontify-buffer)))
613 ;; By default, XEmacs font-lock uses non-duplicable text 615 ;; By default, XEmacs font-lock uses non-duplicable text
614 ;; properties. This code forces all the text properties 616 ;; properties. This code forces all the text properties
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index ede80f858bf..392e894965c 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING."
76 ;; Replace `fn' with the actual function name. 76 ;; Replace `fn' with the actual function name.
77 (if (consp def) "anonymous" def) 77 (if (consp def) "anonymous" def)
78 (match-string 1 docstring)) 78 (match-string 1 docstring))
79 (substring docstring 0 (match-beginning 0))))) 79 (unless (zerop (match-beginning 0))
80 (substring docstring 0 (match-beginning 0))))))
80 81
82;; FIXME: Move to subr.el?
81(defun help-add-fundoc-usage (docstring arglist) 83(defun help-add-fundoc-usage (docstring arglist)
82 "Add the usage info to DOCSTRING. 84 "Add the usage info to DOCSTRING.
83If DOCSTRING already has a usage info, then just return it unchanged. 85If DOCSTRING already has a usage info, then just return it unchanged.
84The usage info is built from ARGLIST. DOCSTRING can be nil. 86The usage info is built from ARGLIST. DOCSTRING can be nil.
85ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." 87ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
86 (unless (stringp docstring) (setq docstring "Not documented")) 88 (unless (stringp docstring) (setq docstring ""))
87 (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t)) 89 (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
90 (eq arglist t))
88 docstring 91 docstring
89 (concat docstring 92 (concat docstring
90 (if (string-match "\n?\n\\'" docstring) 93 (if (string-match "\n?\n\\'" docstring)
@@ -95,18 +98,52 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
95 (concat "(fn" (match-string 1 arglist) ")") 98 (concat "(fn" (match-string 1 arglist) ")")
96 (format "%S" (help-make-usage 'fn arglist)))))) 99 (format "%S" (help-make-usage 'fn arglist))))))
97 100
101;; FIXME: Move to subr.el?
98(defun help-function-arglist (def) 102(defun help-function-arglist (def)
99 ;; Handle symbols aliased to other symbols. 103 ;; Handle symbols aliased to other symbols.
100 (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) 104 (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
101 ;; If definition is a macro, find the function inside it. 105 ;; If definition is a macro, find the function inside it.
102 (if (eq (car-safe def) 'macro) (setq def (cdr def))) 106 (if (eq (car-safe def) 'macro) (setq def (cdr def)))
103 (cond 107 (cond
108 ((and (byte-code-function-p def) (integerp (aref def 0)))
109 (let* ((args-desc (aref def 0))
110 (max (lsh args-desc -8))
111 (min (logand args-desc 127))
112 (rest (logand args-desc 128))
113 (arglist ()))
114 (dotimes (i min)
115 (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
116 (when (> max min)
117 (push '&optional arglist)
118 (dotimes (i (- max min))
119 (push (intern (concat "arg" (number-to-string (+ 1 i min))))
120 arglist)))
121 (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
122 (nreverse arglist)))
104 ((byte-code-function-p def) (aref def 0)) 123 ((byte-code-function-p def) (aref def 0))
105 ((eq (car-safe def) 'lambda) (nth 1 def)) 124 ((eq (car-safe def) 'lambda) (nth 1 def))
125 ((eq (car-safe def) 'closure) (nth 2 def))
126 ((subrp def)
127 (let ((arity (subr-arity def))
128 (arglist ()))
129 (dotimes (i (car arity))
130 (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
131 (cond
132 ((not (numberp (cdr arglist)))
133 (push '&rest arglist)
134 (push 'rest arglist))
135 ((< (car arity) (cdr arity))
136 (push '&optional arglist)
137 (dotimes (i (- (cdr arity) (car arity)))
138 (push (intern (concat "arg" (number-to-string
139 (+ 1 i (car arity)))))
140 arglist))))
141 (nreverse arglist)))
106 ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) 142 ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
107 "[Arg list not available until function definition is loaded.]") 143 "[Arg list not available until function definition is loaded.]")
108 (t t))) 144 (t t)))
109 145
146;; FIXME: Move to subr.el?
110(defun help-make-usage (function arglist) 147(defun help-make-usage (function arglist)
111 (cons (if (symbolp function) function 'anonymous) 148 (cons (if (symbolp function) function 'anonymous)
112 (mapcar (lambda (arg) 149 (mapcar (lambda (arg)
@@ -117,8 +154,11 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
117 (cdr arg)) 154 (cdr arg))
118 arg) 155 arg)
119 (let ((name (symbol-name arg))) 156 (let ((name (symbol-name arg)))
120 (if (string-match "\\`&" name) arg 157 (cond
121 (intern (upcase name)))))) 158 ((string-match "\\`&" name) arg)
159 ((string-match "\\`_" name)
160 (intern (upcase (substring name 1))))
161 (t (intern (upcase name)))))))
122 arglist))) 162 arglist)))
123 163
124;; Could be this, if we make symbol-file do the work below. 164;; Could be this, if we make symbol-file do the work below.
@@ -190,7 +230,7 @@ if the variable `help-downcase-arguments' is non-nil."
190 doc t t 1))))) 230 doc t t 1)))))
191 231
192(defun help-highlight-arguments (usage doc &rest args) 232(defun help-highlight-arguments (usage doc &rest args)
193 (when usage 233 (when (and usage (string-match "^(" usage))
194 (with-temp-buffer 234 (with-temp-buffer
195 (insert usage) 235 (insert usage)
196 (goto-char (point-min)) 236 (goto-char (point-min))
@@ -353,8 +393,7 @@ suitable file is found, return nil."
353 (pt1 (with-current-buffer (help-buffer) (point))) 393 (pt1 (with-current-buffer (help-buffer) (point)))
354 errtype) 394 errtype)
355 (setq string 395 (setq string
356 (cond ((or (stringp def) 396 (cond ((or (stringp def) (vectorp def))
357 (vectorp def))
358 "a keyboard macro") 397 "a keyboard macro")
359 ((subrp def) 398 ((subrp def)
360 (if (eq 'unevalled (cdr (subr-arity def))) 399 (if (eq 'unevalled (cdr (subr-arity def)))
@@ -373,6 +412,8 @@ suitable file is found, return nil."
373 (concat beg "Lisp function")) 412 (concat beg "Lisp function"))
374 ((eq (car-safe def) 'macro) 413 ((eq (car-safe def) 'macro)
375 "a Lisp macro") 414 "a Lisp macro")
415 ((eq (car-safe def) 'closure)
416 (concat beg "Lisp closure"))
376 ((eq (car-safe def) 'autoload) 417 ((eq (car-safe def) 'autoload)
377 (format "%s autoloaded %s" 418 (format "%s autoloaded %s"
378 (if (commandp def) "an interactive" "an") 419 (if (commandp def) "an interactive" "an")
@@ -593,10 +634,9 @@ it is displayed along with the global value."
593 "Describe variable (default %s): " v) 634 "Describe variable (default %s): " v)
594 "Describe variable: ") 635 "Describe variable: ")
595 obarray 636 obarray
596 (lambda (vv) 637 (lambda (vv)
597 (and (not (keywordp vv)) 638 (or (special-variable-p vv)
598 (or (boundp vv) 639 (get vv 'variable-documentation)))
599 (get vv 'variable-documentation))))
600 t nil nil 640 t nil nil
601 (if (symbolp v) (symbol-name v)))) 641 (if (symbolp v) (symbol-name v))))
602 (list (if (equal val "") 642 (list (if (equal val "")
diff --git a/lisp/ielm.el b/lisp/ielm.el
index a5731eb09e2..a1057303743 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -371,7 +371,8 @@ simply inserts a newline."
371 (*** *3)) 371 (*** *3))
372 (kill-buffer (current-buffer)) 372 (kill-buffer (current-buffer))
373 (set-buffer ielm-wbuf) 373 (set-buffer ielm-wbuf)
374 (setq ielm-result (eval ielm-form)) 374 (setq ielm-result
375 (eval ielm-form lexical-binding))
375 (setq ielm-wbuf (current-buffer)) 376 (setq ielm-wbuf (current-buffer))
376 (setq 377 (setq
377 ielm-temp-buffer 378 ielm-temp-buffer
diff --git a/lisp/info.el b/lisp/info.el
index fb753659737..34c486d3754 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -4930,6 +4930,27 @@ type returned by `Info-bookmark-make-record', which see."
4930 (bookmark-default-handler 4930 (bookmark-default-handler
4931 `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) 4931 `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk)))))
4932 4932
4933
4934;;;###autoload
4935(defun info-display-manual (manual)
4936 "Go to Info buffer that displays MANUAL, creating it if none already exists."
4937 (interactive "sManual name: ")
4938 (let ((blist (buffer-list))
4939 (manual-re (concat "\\(/\\|\\`\\)" manual "\\(\\.\\|\\'\\)"))
4940 (case-fold-search t)
4941 found)
4942 (dolist (buffer blist)
4943 (with-current-buffer buffer
4944 (when (and (eq major-mode 'Info-mode)
4945 (stringp Info-current-file)
4946 (string-match manual-re Info-current-file))
4947 (setq found buffer
4948 blist nil))))
4949 (if found
4950 (pop-to-buffer found)
4951 (info-initialize)
4952 (info (Info-find-file manual)))))
4953
4933(provide 'info) 4954(provide 'info)
4934 4955
4935;;; info.el ends here 4956;;; info.el ends here
diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in
index 0e3d54408fd..ed2fe4031b7 100644
--- a/lisp/makefile.w32-in
+++ b/lisp/makefile.w32-in
@@ -66,6 +66,15 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
66 $(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \ 66 $(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \
67 $(lisp)/cedet/srecode/loaddefs.el 67 $(lisp)/cedet/srecode/loaddefs.el
68 68
69# Value of max-lisp-eval-depth when compiling initially.
70# During bootstrapping the byte-compiler is run interpreted when compiling
71# itself, and uses more stack than usual.
72#
73BIG_STACK_DEPTH = 1200
74BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
75
76BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
77
69# Files to compile before others during a bootstrap. This is done to 78# Files to compile before others during a bootstrap. This is done to
70# speed up the bootstrap process. The CC files are compiled first 79# speed up the bootstrap process. The CC files are compiled first
71# because CC mode tweaks the compilation process, and requiring 80# because CC mode tweaks the compilation process, and requiring
@@ -75,6 +84,8 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
75COMPILE_FIRST = \ 84COMPILE_FIRST = \
76 $(lisp)/emacs-lisp/byte-opt.el \ 85 $(lisp)/emacs-lisp/byte-opt.el \
77 $(lisp)/emacs-lisp/bytecomp.el \ 86 $(lisp)/emacs-lisp/bytecomp.el \
87 $(lisp)/emacs-lisp/macroexp.el \
88 $(lisp)/emacs-lisp/cconv.el \
78 $(lisp)/subr.el \ 89 $(lisp)/subr.el \
79 $(lisp)/progmodes/cc-mode.el \ 90 $(lisp)/progmodes/cc-mode.el \
80 $(lisp)/progmodes/cc-vars.el 91 $(lisp)/progmodes/cc-vars.el
@@ -287,7 +298,7 @@ TAGS-LISP-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsf
287.SUFFIXES: .elc .el 298.SUFFIXES: .elc .el
288 299
289.el.elc: 300.el.elc:
290 -$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< 301 -$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
291 302
292# Compile all Lisp files, but don't recompile those that are up to 303# Compile all Lisp files, but don't recompile those that are up to
293# date. Some files don't actually get compiled because they set the 304# date. Some files don't actually get compiled because they set the
@@ -307,22 +318,22 @@ compile: $(lisp)/subdirs.el mh-autoloads compile-$(SHELLTYPE) doit
307compile-CMD: 318compile-CMD:
308# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g 319# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
309 for %%f in ($(COMPILE_FIRST)) do \ 320 for %%f in ($(COMPILE_FIRST)) do \
310 $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f 321 $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f
311 for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \ 322 for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \
312 $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g 323 $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g
313 324
314compile-SH: 325compile-SH:
315# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done 326# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
316 for el in $(COMPILE_FIRST); do \ 327 for el in $(COMPILE_FIRST); do \
317 echo Compiling $$el; \ 328 echo Compiling $$el; \
318 $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ 329 $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
319 done 330 done
320 for dir in $(lisp) $(WINS); do \ 331 for dir in $(lisp) $(WINS); do \
321 for el in $$dir/*.el; do \ 332 for el in $$dir/*.el; do \
322 if test -f $$el; \ 333 if test -f $$el; \
323 then \ 334 then \
324 echo Compiling $$el; \ 335 echo Compiling $$el; \
325 $(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \ 336 $(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
326 fi \ 337 fi \
327 done; \ 338 done; \
328 done 339 done
@@ -335,31 +346,31 @@ compile-always: $(lisp)/subdirs.el compile-always-$(SHELLTYPE) doit
335 346
336compile-always-CMD: 347compile-always-CMD:
337# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g 348# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
338 for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f 349 for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
339 for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f/%%g 350 for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f/%%g
340 351
341compile-always-SH: 352compile-always-SH:
342# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done 353# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
343 for el in $(COMPILE_FIRST); do \ 354 for el in $(COMPILE_FIRST); do \
344 echo Compiling $$el; \ 355 echo Compiling $$el; \
345 $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ 356 $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
346 done 357 done
347 for dir in $(lisp) $(WINS); do \ 358 for dir in $(lisp) $(WINS); do \
348 for el in $$dir/*.el; do \ 359 for el in $$dir/*.el; do \
349 echo Compiling $$el; \ 360 echo Compiling $$el; \
350 $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ 361 $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
351 done; \ 362 done; \
352 done 363 done
353 364
354compile-calc: compile-calc-$(SHELLTYPE) 365compile-calc: compile-calc-$(SHELLTYPE)
355 366
356compile-calc-CMD: 367compile-calc-CMD:
357 for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f 368 for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
358 369
359compile-calc-SH: 370compile-calc-SH:
360 for el in $(lisp)/calc/*.el; do \ 371 for el in $(lisp)/calc/*.el; do \
361 echo Compiling $$el; \ 372 echo Compiling $$el; \
362 $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ 373 $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
363 done 374 done
364 375
365# Backup compiled Lisp files in elc.tar.gz. If that file already 376# Backup compiled Lisp files in elc.tar.gz. If that file already
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 4aa34698809..83358ba2f01 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1,4 +1,4 @@
1;;; minibuffer.el --- Minibuffer completion functions 1;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2008-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
4 4
@@ -133,8 +133,8 @@ the closest directory separators."
133 "Apply FUN to each element of XS in turn. 133 "Apply FUN to each element of XS in turn.
134Return the first non-nil returned value. 134Return the first non-nil returned value.
135Like CL's `some'." 135Like CL's `some'."
136 (lexical-let ((firsterror nil) 136 (let ((firsterror nil)
137 res) 137 res)
138 (while (and (not res) xs) 138 (while (and (not res) xs)
139 (condition-case err 139 (condition-case err
140 (setq res (funcall fun (pop xs))) 140 (setq res (funcall fun (pop xs)))
@@ -171,16 +171,15 @@ FUN will be called in the buffer from which the minibuffer was entered.
171The result of the `completion-table-dynamic' form is a function 171The result of the `completion-table-dynamic' form is a function
172that can be used as the COLLECTION argument to `try-completion' and 172that can be used as the COLLECTION argument to `try-completion' and
173`all-completions'. See Info node `(elisp)Programmed Completion'." 173`all-completions'. See Info node `(elisp)Programmed Completion'."
174 (lexical-let ((fun fun)) 174 (lambda (string pred action)
175 (lambda (string pred action) 175 (if (eq (car-safe action) 'boundaries)
176 (if (eq (car-safe action) 'boundaries) 176 ;; `fun' is not supposed to return another function but a plain old
177 ;; `fun' is not supposed to return another function but a plain old 177 ;; completion table, whose boundaries are always trivial.
178 ;; completion table, whose boundaries are always trivial. 178 nil
179 nil 179 (with-current-buffer (let ((win (minibuffer-selected-window)))
180 (with-current-buffer (let ((win (minibuffer-selected-window))) 180 (if (window-live-p win) (window-buffer win)
181 (if (window-live-p win) (window-buffer win) 181 (current-buffer)))
182 (current-buffer))) 182 (complete-with-action action (funcall fun string) string pred)))))
183 (complete-with-action action (funcall fun string) string pred))))))
184 183
185(defmacro lazy-completion-table (var fun) 184(defmacro lazy-completion-table (var fun)
186 "Initialize variable VAR as a lazy completion table. 185 "Initialize variable VAR as a lazy completion table.
@@ -209,19 +208,18 @@ You should give VAR a non-nil `risky-local-variable' property."
209 ;; Notice that `pred' may not be a function in some abusive cases. 208 ;; Notice that `pred' may not be a function in some abusive cases.
210 (when (functionp pred) 209 (when (functionp pred)
211 (setq pred 210 (setq pred
212 (lexical-let ((pred pred)) 211 ;; Predicates are called differently depending on the nature of
213 ;; Predicates are called differently depending on the nature of 212 ;; the completion table :-(
214 ;; the completion table :-( 213 (cond
215 (cond 214 ((vectorp table) ;Obarray.
216 ((vectorp table) ;Obarray. 215 (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
217 (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) 216 ((hash-table-p table)
218 ((hash-table-p table) 217 (lambda (s _v) (funcall pred (concat prefix s))))
219 (lambda (s v) (funcall pred (concat prefix s)))) 218 ((functionp table)
220 ((functionp table) 219 (lambda (s) (funcall pred (concat prefix s))))
221 (lambda (s) (funcall pred (concat prefix s)))) 220 (t ;Lists and alists.
222 (t ;Lists and alists. 221 (lambda (s)
223 (lambda (s) 222 (funcall pred (concat prefix (if (consp s) (car s) s))))))))
224 (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
225 (if (eq (car-safe action) 'boundaries) 223 (if (eq (car-safe action) 'boundaries)
226 (let* ((len (length prefix)) 224 (let* ((len (length prefix))
227 (bound (completion-boundaries string table pred (cdr action)))) 225 (bound (completion-boundaries string table pred (cdr action))))
@@ -300,11 +298,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
300 (t 298 (t
301 (or (complete-with-action action table string 299 (or (complete-with-action action table string
302 (if (null pred2) pred1 300 (if (null pred2) pred1
303 (lexical-let ((pred1 pred2) (pred2 pred2)) 301 (lambda (x)
304 (lambda (x) 302 ;; Call `pred1' first, so that `pred2'
305 ;; Call `pred1' first, so that `pred2' 303 ;; really can't tell that `x' is in table.
306 ;; really can't tell that `x' is in table. 304 (if (funcall pred1 x) (funcall pred2 x)))))
307 (if (funcall pred1 x) (funcall pred2 x))))))
308 ;; If completion failed and we're not applying pred1 strictly, try 305 ;; If completion failed and we're not applying pred1 strictly, try
309 ;; again without pred1. 306 ;; again without pred1.
310 (and (not strict) 307 (and (not strict)
@@ -314,11 +311,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
314 "Create a completion table that tries each table in TABLES in turn." 311 "Create a completion table that tries each table in TABLES in turn."
315 ;; FIXME: the boundaries may come from TABLE1 even when the completion list 312 ;; FIXME: the boundaries may come from TABLE1 even when the completion list
316 ;; is returned by TABLE2 (because TABLE1 returned an empty list). 313 ;; is returned by TABLE2 (because TABLE1 returned an empty list).
317 (lexical-let ((tables tables)) 314 (lambda (string pred action)
318 (lambda (string pred action) 315 (completion--some (lambda (table)
319 (completion--some (lambda (table) 316 (complete-with-action action table string pred))
320 (complete-with-action action table string pred)) 317 tables)))
321 tables))))
322 318
323;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) 319;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
324;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) 320;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
@@ -560,16 +556,15 @@ E = after completion we now have an Exact match.
560 101 5 ??? impossible 556 101 5 ??? impossible
561 110 6 some completion happened 557 110 6 some completion happened
562 111 7 completed to an exact completion" 558 111 7 completed to an exact completion"
563 (lexical-let* 559 (let* ((beg (field-beginning))
564 ((beg (field-beginning)) 560 (end (field-end))
565 (end (field-end)) 561 (string (buffer-substring beg end))
566 (string (buffer-substring beg end)) 562 (comp (funcall (or try-completion-function
567 (comp (funcall (or try-completion-function 563 'completion-try-completion)
568 'completion-try-completion) 564 string
569 string 565 minibuffer-completion-table
570 minibuffer-completion-table 566 minibuffer-completion-predicate
571 minibuffer-completion-predicate 567 (- (point) beg))))
572 (- (point) beg))))
573 (cond 568 (cond
574 ((null comp) 569 ((null comp)
575 (minibuffer-hide-completions) 570 (minibuffer-hide-completions)
@@ -584,13 +579,12 @@ E = after completion we now have an Exact match.
584 ;; `completed' should be t if some completion was done, which doesn't 579 ;; `completed' should be t if some completion was done, which doesn't
585 ;; include simply changing the case of the entered string. However, 580 ;; include simply changing the case of the entered string. However,
586 ;; for appearance, the string is rewritten if the case changes. 581 ;; for appearance, the string is rewritten if the case changes.
587 (lexical-let* 582 (let* ((comp-pos (cdr comp))
588 ((comp-pos (cdr comp)) 583 (completion (car comp))
589 (completion (car comp)) 584 (completed (not (eq t (compare-strings completion nil nil
590 (completed (not (eq t (compare-strings completion nil nil 585 string nil nil t))))
591 string nil nil t)))) 586 (unchanged (eq t (compare-strings completion nil nil
592 (unchanged (eq t (compare-strings completion nil nil 587 string nil nil nil))))
593 string nil nil nil))))
594 (if unchanged 588 (if unchanged
595 (goto-char end) 589 (goto-char end)
596 ;; Insert in minibuffer the chars we got. 590 ;; Insert in minibuffer the chars we got.
@@ -672,16 +666,16 @@ scroll the window of possible completions."
672 (setq minibuffer-scroll-window nil)) 666 (setq minibuffer-scroll-window nil))
673 667
674 (cond 668 (cond
675 ;; If there's a fresh completion window with a live buffer, 669 ;; If there's a fresh completion window with a live buffer,
676 ;; and this command is repeated, scroll that window. 670 ;; and this command is repeated, scroll that window.
677 ((window-live-p minibuffer-scroll-window) 671 ((window-live-p minibuffer-scroll-window)
678 (let ((window minibuffer-scroll-window)) 672 (let ((window minibuffer-scroll-window))
679 (with-current-buffer (window-buffer window) 673 (with-current-buffer (window-buffer window)
680 (if (pos-visible-in-window-p (point-max) window) 674 (if (pos-visible-in-window-p (point-max) window)
681 ;; If end is in view, scroll up to the beginning. 675 ;; If end is in view, scroll up to the beginning.
682 (set-window-start window (point-min) nil) 676 (set-window-start window (point-min) nil)
683 ;; Else scroll down one screen. 677 ;; Else scroll down one screen.
684 (scroll-other-window)) 678 (scroll-other-window))
685 nil))) 679 nil)))
686 ;; If we're cycling, keep on cycling. 680 ;; If we're cycling, keep on cycling.
687 ((and completion-cycling completion-all-sorted-completions) 681 ((and completion-cycling completion-all-sorted-completions)
@@ -695,7 +689,7 @@ scroll the window of possible completions."
695 t) 689 t)
696 (t t))))) 690 (t t)))))
697 691
698(defun completion--flush-all-sorted-completions (&rest ignore) 692(defun completion--flush-all-sorted-completions (&rest _ignore)
699 (remove-hook 'after-change-functions 693 (remove-hook 'after-change-functions
700 'completion--flush-all-sorted-completions t) 694 'completion--flush-all-sorted-completions t)
701 (setq completion-cycling nil) 695 (setq completion-cycling nil)
@@ -783,8 +777,8 @@ If `minibuffer-completion-confirm' is `confirm-after-completion',
783 `minibuffer-confirm-exit-commands', and accept the input 777 `minibuffer-confirm-exit-commands', and accept the input
784 otherwise." 778 otherwise."
785 (interactive) 779 (interactive)
786 (lexical-let ((beg (field-beginning)) 780 (let ((beg (field-beginning))
787 (end (field-end))) 781 (end (field-end)))
788 (cond 782 (cond
789 ;; Allow user to specify null string 783 ;; Allow user to specify null string
790 ((= beg end) (exit-minibuffer)) 784 ((= beg end) (exit-minibuffer))
@@ -1029,7 +1023,7 @@ It also eliminates runs of equal strings."
1029 'mouse-face 'highlight) 1023 'mouse-face 'highlight)
1030 (add-text-properties (point) (progn (insert (cadr str)) (point)) 1024 (add-text-properties (point) (progn (insert (cadr str)) (point))
1031 '(mouse-face nil 1025 '(mouse-face nil
1032 face completions-annotations))) 1026 face completions-annotations)))
1033 (cond 1027 (cond
1034 ((eq completions-format 'vertical) 1028 ((eq completions-format 'vertical)
1035 ;; Vertical format 1029 ;; Vertical format
@@ -1161,14 +1155,14 @@ variables.")
1161 "Display a list of possible completions of the current minibuffer contents." 1155 "Display a list of possible completions of the current minibuffer contents."
1162 (interactive) 1156 (interactive)
1163 (message "Making completion list...") 1157 (message "Making completion list...")
1164 (lexical-let* ((start (field-beginning)) 1158 (let* ((start (field-beginning))
1165 (end (field-end)) 1159 (end (field-end))
1166 (string (field-string)) 1160 (string (field-string))
1167 (completions (completion-all-completions 1161 (completions (completion-all-completions
1168 string 1162 string
1169 minibuffer-completion-table 1163 minibuffer-completion-table
1170 minibuffer-completion-predicate 1164 minibuffer-completion-predicate
1171 (- (point) (field-beginning))))) 1165 (- (point) (field-beginning)))))
1172 (message nil) 1166 (message nil)
1173 (if (and completions 1167 (if (and completions
1174 (or (consp (cdr completions)) 1168 (or (consp (cdr completions))
@@ -1462,7 +1456,7 @@ The completion method is determined by `completion-at-point-functions'."
1462 (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" 1456 (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
1463 "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) 1457 "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
1464 1458
1465(defun completion--embedded-envvar-table (string pred action) 1459(defun completion--embedded-envvar-table (string _pred action)
1466 "Completion table for envvars embedded in a string. 1460 "Completion table for envvars embedded in a string.
1467The envvar syntax (and escaping) rules followed by this table are the 1461The envvar syntax (and escaping) rules followed by this table are the
1468same as `substitute-in-file-name'." 1462same as `substitute-in-file-name'."
@@ -1482,20 +1476,20 @@ same as `substitute-in-file-name'."
1482 ;; other table handle the test-completion case. 1476 ;; other table handle the test-completion case.
1483 nil) 1477 nil)
1484 ((eq (car-safe action) 'boundaries) 1478 ((eq (car-safe action) 'boundaries)
1485 ;; Only return boundaries if there's something to complete, 1479 ;; Only return boundaries if there's something to complete,
1486 ;; since otherwise when we're used in 1480 ;; since otherwise when we're used in
1487 ;; completion-table-in-turn, we could return boundaries and 1481 ;; completion-table-in-turn, we could return boundaries and
1488 ;; let some subsequent table return a list of completions. 1482 ;; let some subsequent table return a list of completions.
1489 ;; FIXME: Maybe it should rather be fixed in 1483 ;; FIXME: Maybe it should rather be fixed in
1490 ;; completion-table-in-turn instead, but it's difficult to 1484 ;; completion-table-in-turn instead, but it's difficult to
1491 ;; do it efficiently there. 1485 ;; do it efficiently there.
1492 (when (try-completion (substring string beg) table nil) 1486 (when (try-completion (substring string beg) table nil)
1493 ;; Compute the boundaries of the subfield to which this 1487 ;; Compute the boundaries of the subfield to which this
1494 ;; completion applies. 1488 ;; completion applies.
1495 (let ((suffix (cdr action))) 1489 (let ((suffix (cdr action)))
1496 (list* 'boundaries 1490 (list* 'boundaries
1497 (or (match-beginning 2) (match-beginning 1)) 1491 (or (match-beginning 2) (match-beginning 1))
1498 (when (string-match "[^[:alnum:]_]" suffix) 1492 (when (string-match "[^[:alnum:]_]" suffix)
1499 (match-beginning 0)))))) 1493 (match-beginning 0))))))
1500 (t 1494 (t
1501 (if (eq (aref string (1- beg)) ?{) 1495 (if (eq (aref string (1- beg)) ?{)
@@ -1510,55 +1504,55 @@ same as `substitute-in-file-name'."
1510(defun completion-file-name-table (string pred action) 1504(defun completion-file-name-table (string pred action)
1511 "Completion table for file names." 1505 "Completion table for file names."
1512 (ignore-errors 1506 (ignore-errors
1513 (cond 1507 (cond
1514 ((eq (car-safe action) 'boundaries) 1508 ((eq (car-safe action) 'boundaries)
1515 (let ((start (length (file-name-directory string))) 1509 (let ((start (length (file-name-directory string)))
1516 (end (string-match-p "/" (cdr action)))) 1510 (end (string-match-p "/" (cdr action))))
1517 (list* 'boundaries 1511 (list* 'boundaries
1518 ;; if `string' is "C:" in w32, (file-name-directory string) 1512 ;; if `string' is "C:" in w32, (file-name-directory string)
1519 ;; returns "C:/", so `start' is 3 rather than 2. 1513 ;; returns "C:/", so `start' is 3 rather than 2.
1520 ;; Not quite sure what is The Right Fix, but clipping it 1514 ;; Not quite sure what is The Right Fix, but clipping it
1521 ;; back to 2 will work for this particular case. We'll 1515 ;; back to 2 will work for this particular case. We'll
1522 ;; see if we can come up with a better fix when we bump 1516 ;; see if we can come up with a better fix when we bump
1523 ;; into more such problematic cases. 1517 ;; into more such problematic cases.
1524 (min start (length string)) end))) 1518 (min start (length string)) end)))
1525 1519
1526 ((eq action 'lambda) 1520 ((eq action 'lambda)
1527 (if (zerop (length string)) 1521 (if (zerop (length string))
1528 nil ;Not sure why it's here, but it probably doesn't harm. 1522 nil ;Not sure why it's here, but it probably doesn't harm.
1529 (funcall (or pred 'file-exists-p) string))) 1523 (funcall (or pred 'file-exists-p) string)))
1530 1524
1531 (t 1525 (t
1532 (let* ((name (file-name-nondirectory string)) 1526 (let* ((name (file-name-nondirectory string))
1533 (specdir (file-name-directory string)) 1527 (specdir (file-name-directory string))
1534 (realdir (or specdir default-directory))) 1528 (realdir (or specdir default-directory)))
1535 1529
1536 (cond 1530 (cond
1537 ((null action) 1531 ((null action)
1538 (let ((comp (file-name-completion name realdir pred))) 1532 (let ((comp (file-name-completion name realdir pred)))
1539 (if (stringp comp) 1533 (if (stringp comp)
1540 (concat specdir comp) 1534 (concat specdir comp)
1541 comp))) 1535 comp)))
1542 1536
1543 ((eq action t) 1537 ((eq action t)
1544 (let ((all (file-name-all-completions name realdir))) 1538 (let ((all (file-name-all-completions name realdir)))
1545 1539
1546 ;; Check the predicate, if necessary. 1540 ;; Check the predicate, if necessary.
1547 (unless (memq pred '(nil file-exists-p)) 1541 (unless (memq pred '(nil file-exists-p))
1548 (let ((comp ()) 1542 (let ((comp ())
1549 (pred 1543 (pred
1550 (if (eq pred 'file-directory-p) 1544 (if (eq pred 'file-directory-p)
1551 ;; Brute-force speed up for directory checking: 1545 ;; Brute-force speed up for directory checking:
1552 ;; Discard strings which don't end in a slash. 1546 ;; Discard strings which don't end in a slash.
1553 (lambda (s) 1547 (lambda (s)
1554 (let ((len (length s))) 1548 (let ((len (length s)))
1555 (and (> len 0) (eq (aref s (1- len)) ?/)))) 1549 (and (> len 0) (eq (aref s (1- len)) ?/))))
1556 ;; Must do it the hard (and slow) way. 1550 ;; Must do it the hard (and slow) way.
1557 pred))) 1551 pred)))
1558 (let ((default-directory (expand-file-name realdir))) 1552 (let ((default-directory (expand-file-name realdir)))
1559 (dolist (tem all) 1553 (dolist (tem all)
1560 (if (funcall pred tem) (push tem comp)))) 1554 (if (funcall pred tem) (push tem comp))))
1561 (setq all (nreverse comp)))) 1555 (setq all (nreverse comp))))
1562 1556
1563 all)))))))) 1557 all))))))))
1564 1558
@@ -1755,122 +1749,122 @@ See `read-file-name' for the meaning of the arguments."
1755 (minibuffer--double-dollars dir))) 1749 (minibuffer--double-dollars dir)))
1756 (initial (cons (minibuffer--double-dollars initial) 0))))) 1750 (initial (cons (minibuffer--double-dollars initial) 0)))))
1757 1751
1758 (let ((completion-ignore-case read-file-name-completion-ignore-case) 1752 (let ((completion-ignore-case read-file-name-completion-ignore-case)
1759 (minibuffer-completing-file-name t) 1753 (minibuffer-completing-file-name t)
1760 (pred (or predicate 'file-exists-p)) 1754 (pred (or predicate 'file-exists-p))
1761 (add-to-history nil)) 1755 (add-to-history nil))
1762 1756
1763 (let* ((val 1757 (let* ((val
1764 (if (or (not (next-read-file-uses-dialog-p)) 1758 (if (or (not (next-read-file-uses-dialog-p))
1765 ;; Graphical file dialogs can't handle remote 1759 ;; Graphical file dialogs can't handle remote
1766 ;; files (Bug#99). 1760 ;; files (Bug#99).
1767 (file-remote-p dir)) 1761 (file-remote-p dir))
1768 ;; We used to pass `dir' to `read-file-name-internal' by 1762 ;; We used to pass `dir' to `read-file-name-internal' by
1769 ;; abusing the `predicate' argument. It's better to 1763 ;; abusing the `predicate' argument. It's better to
1770 ;; just use `default-directory', but in order to avoid 1764 ;; just use `default-directory', but in order to avoid
1771 ;; changing `default-directory' in the current buffer, 1765 ;; changing `default-directory' in the current buffer,
1772 ;; we don't let-bind it. 1766 ;; we don't let-bind it.
1773 (lexical-let ((dir (file-name-as-directory 1767 (let ((dir (file-name-as-directory
1774 (expand-file-name dir)))) 1768 (expand-file-name dir))))
1775 (minibuffer-with-setup-hook 1769 (minibuffer-with-setup-hook
1776 (lambda () 1770 (lambda ()
1777 (setq default-directory dir) 1771 (setq default-directory dir)
1778 ;; When the first default in `minibuffer-default' 1772 ;; When the first default in `minibuffer-default'
1779 ;; duplicates initial input `insdef', 1773 ;; duplicates initial input `insdef',
1780 ;; reset `minibuffer-default' to nil. 1774 ;; reset `minibuffer-default' to nil.
1781 (when (equal (or (car-safe insdef) insdef) 1775 (when (equal (or (car-safe insdef) insdef)
1782 (or (car-safe minibuffer-default) 1776 (or (car-safe minibuffer-default)
1783 minibuffer-default)) 1777 minibuffer-default))
1784 (setq minibuffer-default 1778 (setq minibuffer-default
1785 (cdr-safe minibuffer-default))) 1779 (cdr-safe minibuffer-default)))
1786 ;; On the first request on `M-n' fill 1780 ;; On the first request on `M-n' fill
1787 ;; `minibuffer-default' with a list of defaults 1781 ;; `minibuffer-default' with a list of defaults
1788 ;; relevant for file-name reading. 1782 ;; relevant for file-name reading.
1789 (set (make-local-variable 'minibuffer-default-add-function) 1783 (set (make-local-variable 'minibuffer-default-add-function)
1790 (lambda () 1784 (lambda ()
1791 (with-current-buffer 1785 (with-current-buffer
1792 (window-buffer (minibuffer-selected-window)) 1786 (window-buffer (minibuffer-selected-window))
1793 (read-file-name--defaults dir initial))))) 1787 (read-file-name--defaults dir initial)))))
1794 (completing-read prompt 'read-file-name-internal 1788 (completing-read prompt 'read-file-name-internal
1795 pred mustmatch insdef 1789 pred mustmatch insdef
1796 'file-name-history default-filename))) 1790 'file-name-history default-filename)))
1797 ;; If DEFAULT-FILENAME not supplied and DIR contains 1791 ;; If DEFAULT-FILENAME not supplied and DIR contains
1798 ;; a file name, split it. 1792 ;; a file name, split it.
1799 (let ((file (file-name-nondirectory dir)) 1793 (let ((file (file-name-nondirectory dir))
1800 ;; When using a dialog, revert to nil and non-nil 1794 ;; When using a dialog, revert to nil and non-nil
1801 ;; interpretation of mustmatch. confirm options 1795 ;; interpretation of mustmatch. confirm options
1802 ;; need to be interpreted as nil, otherwise 1796 ;; need to be interpreted as nil, otherwise
1803 ;; it is impossible to create new files using 1797 ;; it is impossible to create new files using
1804 ;; dialogs with the default settings. 1798 ;; dialogs with the default settings.
1805 (dialog-mustmatch 1799 (dialog-mustmatch
1806 (not (memq mustmatch 1800 (not (memq mustmatch
1807 '(nil confirm confirm-after-completion))))) 1801 '(nil confirm confirm-after-completion)))))
1808 (when (and (not default-filename) 1802 (when (and (not default-filename)
1809 (not (zerop (length file)))) 1803 (not (zerop (length file))))
1810 (setq default-filename file) 1804 (setq default-filename file)
1811 (setq dir (file-name-directory dir))) 1805 (setq dir (file-name-directory dir)))
1812 (when default-filename 1806 (when default-filename
1813 (setq default-filename 1807 (setq default-filename
1814 (expand-file-name (if (consp default-filename) 1808 (expand-file-name (if (consp default-filename)
1815 (car default-filename) 1809 (car default-filename)
1816 default-filename) 1810 default-filename)
1817 dir))) 1811 dir)))
1818 (setq add-to-history t) 1812 (setq add-to-history t)
1819 (x-file-dialog prompt dir default-filename 1813 (x-file-dialog prompt dir default-filename
1820 dialog-mustmatch 1814 dialog-mustmatch
1821 (eq predicate 'file-directory-p))))) 1815 (eq predicate 'file-directory-p)))))
1822 1816
1823 (replace-in-history (eq (car-safe file-name-history) val))) 1817 (replace-in-history (eq (car-safe file-name-history) val)))
1824 ;; If completing-read returned the inserted default string itself 1818 ;; If completing-read returned the inserted default string itself
1825 ;; (rather than a new string with the same contents), 1819 ;; (rather than a new string with the same contents),
1826 ;; it has to mean that the user typed RET with the minibuffer empty. 1820 ;; it has to mean that the user typed RET with the minibuffer empty.
1827 ;; In that case, we really want to return "" 1821 ;; In that case, we really want to return ""
1828 ;; so that commands such as set-visited-file-name can distinguish. 1822 ;; so that commands such as set-visited-file-name can distinguish.
1829 (when (consp default-filename) 1823 (when (consp default-filename)
1830 (setq default-filename (car default-filename))) 1824 (setq default-filename (car default-filename)))
1831 (when (eq val default-filename) 1825 (when (eq val default-filename)
1832 ;; In this case, completing-read has not added an element 1826 ;; In this case, completing-read has not added an element
1833 ;; to the history. Maybe we should. 1827 ;; to the history. Maybe we should.
1834 (if (not replace-in-history) 1828 (if (not replace-in-history)
1835 (setq add-to-history t)) 1829 (setq add-to-history t))
1836 (setq val "")) 1830 (setq val ""))
1837 (unless val (error "No file name specified")) 1831 (unless val (error "No file name specified"))
1838 1832
1839 (if (and default-filename 1833 (if (and default-filename
1840 (string-equal val (if (consp insdef) (car insdef) insdef))) 1834 (string-equal val (if (consp insdef) (car insdef) insdef)))
1841 (setq val default-filename)) 1835 (setq val default-filename))
1842 (setq val (substitute-in-file-name val)) 1836 (setq val (substitute-in-file-name val))
1843 1837
1844 (if replace-in-history 1838 (if replace-in-history
1845 ;; Replace what Fcompleting_read added to the history 1839 ;; Replace what Fcompleting_read added to the history
1846 ;; with what we will actually return. As an exception, 1840 ;; with what we will actually return. As an exception,
1847 ;; if that's the same as the second item in 1841 ;; if that's the same as the second item in
1848 ;; file-name-history, it's really a repeat (Bug#4657). 1842 ;; file-name-history, it's really a repeat (Bug#4657).
1843 (let ((val1 (minibuffer--double-dollars val)))
1844 (if history-delete-duplicates
1845 (setcdr file-name-history
1846 (delete val1 (cdr file-name-history))))
1847 (if (string= val1 (cadr file-name-history))
1848 (pop file-name-history)
1849 (setcar file-name-history val1)))
1850 (if add-to-history
1851 ;; Add the value to the history--but not if it matches
1852 ;; the last value already there.
1849 (let ((val1 (minibuffer--double-dollars val))) 1853 (let ((val1 (minibuffer--double-dollars val)))
1850 (if history-delete-duplicates 1854 (unless (and (consp file-name-history)
1851 (setcdr file-name-history 1855 (equal (car file-name-history) val1))
1852 (delete val1 (cdr file-name-history)))) 1856 (setq file-name-history
1853 (if (string= val1 (cadr file-name-history)) 1857 (cons val1
1854 (pop file-name-history) 1858 (if history-delete-duplicates
1855 (setcar file-name-history val1))) 1859 (delete val1 file-name-history)
1856 (if add-to-history 1860 file-name-history)))))))
1857 ;; Add the value to the history--but not if it matches
1858 ;; the last value already there.
1859 (let ((val1 (minibuffer--double-dollars val)))
1860 (unless (and (consp file-name-history)
1861 (equal (car file-name-history) val1))
1862 (setq file-name-history
1863 (cons val1
1864 (if history-delete-duplicates
1865 (delete val1 file-name-history)
1866 file-name-history)))))))
1867 val)))) 1861 val))))
1868 1862
1869(defun internal-complete-buffer-except (&optional buffer) 1863(defun internal-complete-buffer-except (&optional buffer)
1870 "Perform completion on all buffers excluding BUFFER. 1864 "Perform completion on all buffers excluding BUFFER.
1871BUFFER nil or omitted means use the current buffer. 1865BUFFER nil or omitted means use the current buffer.
1872Like `internal-complete-buffer', but removes BUFFER from the completion list." 1866Like `internal-complete-buffer', but removes BUFFER from the completion list."
1873 (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer)))) 1867 (let ((except (if (stringp buffer) buffer (buffer-name buffer))))
1874 (apply-partially 'completion-table-with-predicate 1868 (apply-partially 'completion-table-with-predicate
1875 'internal-complete-buffer 1869 'internal-complete-buffer
1876 (lambda (name) 1870 (lambda (name)
@@ -1879,13 +1873,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
1879 1873
1880;;; Old-style completion, used in Emacs-21 and Emacs-22. 1874;;; Old-style completion, used in Emacs-21 and Emacs-22.
1881 1875
1882(defun completion-emacs21-try-completion (string table pred point) 1876(defun completion-emacs21-try-completion (string table pred _point)
1883 (let ((completion (try-completion string table pred))) 1877 (let ((completion (try-completion string table pred)))
1884 (if (stringp completion) 1878 (if (stringp completion)
1885 (cons completion (length completion)) 1879 (cons completion (length completion))
1886 completion))) 1880 completion)))
1887 1881
1888(defun completion-emacs21-all-completions (string table pred point) 1882(defun completion-emacs21-all-completions (string table pred _point)
1889 (completion-hilit-commonality 1883 (completion-hilit-commonality
1890 (all-completions string table pred) 1884 (all-completions string table pred)
1891 (length string) 1885 (length string)
@@ -1942,10 +1936,9 @@ Return the new suffix."
1942 (substring afterpoint 0 (cdr bounds))))) 1936 (substring afterpoint 0 (cdr bounds)))))
1943 1937
1944(defun completion-basic-try-completion (string table pred point) 1938(defun completion-basic-try-completion (string table pred point)
1945 (lexical-let* 1939 (let* ((beforepoint (substring string 0 point))
1946 ((beforepoint (substring string 0 point)) 1940 (afterpoint (substring string point))
1947 (afterpoint (substring string point)) 1941 (bounds (completion-boundaries beforepoint table pred afterpoint)))
1948 (bounds (completion-boundaries beforepoint table pred afterpoint)))
1949 (if (zerop (cdr bounds)) 1942 (if (zerop (cdr bounds))
1950 ;; `try-completion' may return a subtly different result 1943 ;; `try-completion' may return a subtly different result
1951 ;; than `all+merge', so try to use it whenever possible. 1944 ;; than `all+merge', so try to use it whenever possible.
@@ -1956,30 +1949,28 @@ Return the new suffix."
1956 (concat completion 1949 (concat completion
1957 (completion--merge-suffix completion point afterpoint)) 1950 (completion--merge-suffix completion point afterpoint))
1958 (length completion)))) 1951 (length completion))))
1959 (lexical-let* 1952 (let* ((suffix (substring afterpoint (cdr bounds)))
1960 ((suffix (substring afterpoint (cdr bounds))) 1953 (prefix (substring beforepoint 0 (car bounds)))
1961 (prefix (substring beforepoint 0 (car bounds))) 1954 (pattern (delete
1962 (pattern (delete 1955 "" (list (substring beforepoint (car bounds))
1963 "" (list (substring beforepoint (car bounds)) 1956 'point
1964 'point 1957 (substring afterpoint 0 (cdr bounds)))))
1965 (substring afterpoint 0 (cdr bounds))))) 1958 (all (completion-pcm--all-completions prefix pattern table pred)))
1966 (all (completion-pcm--all-completions prefix pattern table pred)))
1967 (if minibuffer-completing-file-name 1959 (if minibuffer-completing-file-name
1968 (setq all (completion-pcm--filename-try-filter all))) 1960 (setq all (completion-pcm--filename-try-filter all)))
1969 (completion-pcm--merge-try pattern all prefix suffix))))) 1961 (completion-pcm--merge-try pattern all prefix suffix)))))
1970 1962
1971(defun completion-basic-all-completions (string table pred point) 1963(defun completion-basic-all-completions (string table pred point)
1972 (lexical-let* 1964 (let* ((beforepoint (substring string 0 point))
1973 ((beforepoint (substring string 0 point)) 1965 (afterpoint (substring string point))
1974 (afterpoint (substring string point)) 1966 (bounds (completion-boundaries beforepoint table pred afterpoint))
1975 (bounds (completion-boundaries beforepoint table pred afterpoint)) 1967 ;; (suffix (substring afterpoint (cdr bounds)))
1976 (suffix (substring afterpoint (cdr bounds))) 1968 (prefix (substring beforepoint 0 (car bounds)))
1977 (prefix (substring beforepoint 0 (car bounds))) 1969 (pattern (delete
1978 (pattern (delete 1970 "" (list (substring beforepoint (car bounds))
1979 "" (list (substring beforepoint (car bounds)) 1971 'point
1980 'point 1972 (substring afterpoint 0 (cdr bounds)))))
1981 (substring afterpoint 0 (cdr bounds))))) 1973 (all (completion-pcm--all-completions prefix pattern table pred)))
1982 (all (completion-pcm--all-completions prefix pattern table pred)))
1983 (completion-hilit-commonality all point (car bounds)))) 1974 (completion-hilit-commonality all point (car bounds))))
1984 1975
1985;;; Partial-completion-mode style completion. 1976;;; Partial-completion-mode style completion.
@@ -2142,13 +2133,12 @@ POINT is a position inside STRING.
2142FILTER is a function applied to the return value, that can be used, e.g. to 2133FILTER is a function applied to the return value, that can be used, e.g. to
2143filter out additional entries (because TABLE migth not obey PRED)." 2134filter out additional entries (because TABLE migth not obey PRED)."
2144 (unless filter (setq filter 'identity)) 2135 (unless filter (setq filter 'identity))
2145 (lexical-let* 2136 (let* ((beforepoint (substring string 0 point))
2146 ((beforepoint (substring string 0 point)) 2137 (afterpoint (substring string point))
2147 (afterpoint (substring string point)) 2138 (bounds (completion-boundaries beforepoint table pred afterpoint))
2148 (bounds (completion-boundaries beforepoint table pred afterpoint)) 2139 (prefix (substring beforepoint 0 (car bounds)))
2149 (prefix (substring beforepoint 0 (car bounds))) 2140 (suffix (substring afterpoint (cdr bounds)))
2150 (suffix (substring afterpoint (cdr bounds))) 2141 firsterror)
2151 firsterror)
2152 (setq string (substring string (car bounds) (+ point (cdr bounds)))) 2142 (setq string (substring string (car bounds) (+ point (cdr bounds))))
2153 (let* ((relpoint (- point (car bounds))) 2143 (let* ((relpoint (- point (car bounds)))
2154 (pattern (completion-pcm--string->pattern string relpoint)) 2144 (pattern (completion-pcm--string->pattern string relpoint))
@@ -2163,7 +2153,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
2163 ;; The prefix has no completions at all, so we should try and fix 2153 ;; The prefix has no completions at all, so we should try and fix
2164 ;; that first. 2154 ;; that first.
2165 (let ((substring (substring prefix 0 -1))) 2155 (let ((substring (substring prefix 0 -1)))
2166 (destructuring-bind (subpat suball subprefix subsuffix) 2156 (destructuring-bind (subpat suball subprefix _subsuffix)
2167 (completion-pcm--find-all-completions 2157 (completion-pcm--find-all-completions
2168 substring table pred (length substring) filter) 2158 substring table pred (length substring) filter)
2169 (let ((sep (aref prefix (1- (length prefix)))) 2159 (let ((sep (aref prefix (1- (length prefix))))
@@ -2228,7 +2218,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
2228 (list pattern all prefix suffix))))) 2218 (list pattern all prefix suffix)))))
2229 2219
2230(defun completion-pcm-all-completions (string table pred point) 2220(defun completion-pcm-all-completions (string table pred point)
2231 (destructuring-bind (pattern all &optional prefix suffix) 2221 (destructuring-bind (pattern all &optional prefix _suffix)
2232 (completion-pcm--find-all-completions string table pred point) 2222 (completion-pcm--find-all-completions string table pred point)
2233 (when all 2223 (when all
2234 (nconc (completion-pcm--hilit-commonality pattern all) 2224 (nconc (completion-pcm--hilit-commonality pattern all)
@@ -2323,9 +2313,9 @@ filter out additional entries (because TABLE migth not obey PRED)."
2323 2313
2324(defun completion-pcm--pattern->string (pattern) 2314(defun completion-pcm--pattern->string (pattern)
2325 (mapconcat (lambda (x) (cond 2315 (mapconcat (lambda (x) (cond
2326 ((stringp x) x) 2316 ((stringp x) x)
2327 ((eq x 'star) "*") 2317 ((eq x 'star) "*")
2328 (t ""))) ;any, point, prefix. 2318 (t ""))) ;any, point, prefix.
2329 pattern 2319 pattern
2330 "")) 2320 ""))
2331 2321
@@ -2341,7 +2331,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
2341;; second alternative. 2331;; second alternative.
2342(defun completion-pcm--filename-try-filter (all) 2332(defun completion-pcm--filename-try-filter (all)
2343 "Filter to adjust `all' file completion to the behavior of `try'." 2333 "Filter to adjust `all' file completion to the behavior of `try'."
2344 (when all 2334 (when all
2345 (let ((try ()) 2335 (let ((try ())
2346 (re (concat "\\(?:\\`\\.\\.?/\\|" 2336 (re (concat "\\(?:\\`\\.\\.?/\\|"
2347 (regexp-opt completion-ignored-extensions) 2337 (regexp-opt completion-ignored-extensions)
@@ -2359,23 +2349,23 @@ filter out additional entries (because TABLE migth not obey PRED)."
2359 (equal (completion-pcm--pattern->string pattern) (car all))) 2349 (equal (completion-pcm--pattern->string pattern) (car all)))
2360 t) 2350 t)
2361 (t 2351 (t
2362 (let* ((mergedpat (completion-pcm--merge-completions all pattern)) 2352 (let* ((mergedpat (completion-pcm--merge-completions all pattern))
2363 ;; `mergedpat' is in reverse order. Place new point (by 2353 ;; `mergedpat' is in reverse order. Place new point (by
2364 ;; order of preference) either at the old point, or at 2354 ;; order of preference) either at the old point, or at
2365 ;; the last place where there's something to choose, or 2355 ;; the last place where there's something to choose, or
2366 ;; at the very end. 2356 ;; at the very end.
2367 (pointpat (or (memq 'point mergedpat) 2357 (pointpat (or (memq 'point mergedpat)
2368 (memq 'any mergedpat) 2358 (memq 'any mergedpat)
2369 (memq 'star mergedpat) 2359 (memq 'star mergedpat)
2370 ;; Not `prefix'. 2360 ;; Not `prefix'.
2371 mergedpat)) 2361 mergedpat))
2372 ;; New pos from the start. 2362 ;; New pos from the start.
2373 (newpos (length (completion-pcm--pattern->string pointpat))) 2363 (newpos (length (completion-pcm--pattern->string pointpat)))
2374 ;; Do it afterwards because it changes `pointpat' by sideeffect. 2364 ;; Do it afterwards because it changes `pointpat' by sideeffect.
2375 (merged (completion-pcm--pattern->string (nreverse mergedpat)))) 2365 (merged (completion-pcm--pattern->string (nreverse mergedpat))))
2376 2366
2377 (setq suffix (completion--merge-suffix merged newpos suffix)) 2367 (setq suffix (completion--merge-suffix merged newpos suffix))
2378 (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) 2368 (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
2379 2369
2380(defun completion-pcm-try-completion (string table pred point) 2370(defun completion-pcm-try-completion (string table pred point)
2381 (destructuring-bind (pattern all prefix suffix) 2371 (destructuring-bind (pattern all prefix suffix)
@@ -2403,14 +2393,14 @@ filter out additional entries (because TABLE migth not obey PRED)."
2403 (list all pattern prefix suffix (car bounds)))) 2393 (list all pattern prefix suffix (car bounds))))
2404 2394
2405(defun completion-substring-try-completion (string table pred point) 2395(defun completion-substring-try-completion (string table pred point)
2406 (destructuring-bind (all pattern prefix suffix carbounds) 2396 (destructuring-bind (all pattern prefix suffix _carbounds)
2407 (completion-substring--all-completions string table pred point) 2397 (completion-substring--all-completions string table pred point)
2408 (if minibuffer-completing-file-name 2398 (if minibuffer-completing-file-name
2409 (setq all (completion-pcm--filename-try-filter all))) 2399 (setq all (completion-pcm--filename-try-filter all)))
2410 (completion-pcm--merge-try pattern all prefix suffix))) 2400 (completion-pcm--merge-try pattern all prefix suffix)))
2411 2401
2412(defun completion-substring-all-completions (string table pred point) 2402(defun completion-substring-all-completions (string table pred point)
2413 (destructuring-bind (all pattern prefix suffix carbounds) 2403 (destructuring-bind (all pattern prefix _suffix _carbounds)
2414 (completion-substring--all-completions string table pred point) 2404 (completion-substring--all-completions string table pred point)
2415 (when all 2405 (when all
2416 (nconc (completion-pcm--hilit-commonality pattern all) 2406 (nconc (completion-pcm--hilit-commonality pattern all)
@@ -2447,12 +2437,12 @@ filter out additional entries (because TABLE migth not obey PRED)."
2447 (concat (substring str 0 (car bounds)) 2437 (concat (substring str 0 (car bounds))
2448 (mapconcat 'string (substring str (car bounds)) sep)))))))) 2438 (mapconcat 'string (substring str (car bounds)) sep))))))))
2449 2439
2450(defun completion-initials-all-completions (string table pred point) 2440(defun completion-initials-all-completions (string table pred _point)
2451 (let ((newstr (completion-initials-expand string table pred))) 2441 (let ((newstr (completion-initials-expand string table pred)))
2452 (when newstr 2442 (when newstr
2453 (completion-pcm-all-completions newstr table pred (length newstr))))) 2443 (completion-pcm-all-completions newstr table pred (length newstr)))))
2454 2444
2455(defun completion-initials-try-completion (string table pred point) 2445(defun completion-initials-try-completion (string table pred _point)
2456 (let ((newstr (completion-initials-expand string table pred))) 2446 (let ((newstr (completion-initials-expand string table pred)))
2457 (when newstr 2447 (when newstr
2458 (completion-pcm-try-completion newstr table pred (length newstr))))) 2448 (completion-pcm-try-completion newstr table pred (length newstr)))))
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 8feddf8829b..b1e4d860cca 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -1,4 +1,4 @@
1;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*- 1;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8; lexical-binding: t -*-
2 2
3;; Copyright (C) 2006-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
4 4
@@ -341,9 +341,7 @@ CMD can be a string which is passed as-is to MPD or a list of strings
341which will be concatenated with proper quoting before passing them to MPD." 341which will be concatenated with proper quoting before passing them to MPD."
342 (let ((proc (mpc-proc))) 342 (let ((proc (mpc-proc)))
343 (if (and callback (not (process-get proc 'ready))) 343 (if (and callback (not (process-get proc 'ready)))
344 (lexical-let ((old (process-get proc 'callback)) 344 (let ((old (process-get proc 'callback)))
345 (callback callback)
346 (cmd cmd))
347 (process-put proc 'callback 345 (process-put proc 'callback
348 (lambda () 346 (lambda ()
349 (funcall old) 347 (funcall old)
@@ -359,15 +357,14 @@ which will be concatenated with proper quoting before passing them to MPD."
359 (mapconcat 'mpc--proc-quote-string cmd " ")) 357 (mapconcat 'mpc--proc-quote-string cmd " "))
360 "\n"))) 358 "\n")))
361 (if callback 359 (if callback
362 (lexical-let ((buf (current-buffer)) 360 ;; (let ((buf (current-buffer)))
363 (callback callback))
364 (process-put proc 'callback 361 (process-put proc 'callback
365 callback 362 callback
366 ;; (lambda () 363 ;; (lambda ()
367 ;; (funcall callback 364 ;; (funcall callback
368 ;; (prog1 (current-buffer) 365 ;; (prog1 (current-buffer)
369 ;; (set-buffer buf)))) 366 ;; (set-buffer buf)))))
370 )) 367 )
371 ;; If `callback' is nil, we're executing synchronously. 368 ;; If `callback' is nil, we're executing synchronously.
372 (process-put proc 'callback 'ignore) 369 (process-put proc 'callback 'ignore)
373 ;; This returns the process's buffer. 370 ;; This returns the process's buffer.
@@ -402,8 +399,7 @@ which will be concatenated with proper quoting before passing them to MPD."
402 399
403(defun mpc-proc-cmd-to-alist (cmd &optional callback) 400(defun mpc-proc-cmd-to-alist (cmd &optional callback)
404 (if callback 401 (if callback
405 (lexical-let ((buf (current-buffer)) 402 (let ((buf (current-buffer)))
406 (callback callback))
407 (mpc-proc-cmd cmd (lambda () 403 (mpc-proc-cmd cmd (lambda ()
408 (funcall callback (prog1 (mpc-proc-buf-to-alist 404 (funcall callback (prog1 (mpc-proc-buf-to-alist
409 (current-buffer)) 405 (current-buffer))
@@ -522,7 +518,7 @@ to call FUN for any change whatsoever.")
522 518
523(defun mpc-status-refresh (&optional callback) 519(defun mpc-status-refresh (&optional callback)
524 "Refresh `mpc-status'." 520 "Refresh `mpc-status'."
525 (lexical-let ((cb callback)) 521 (let ((cb callback))
526 (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong")) 522 (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
527 (lambda () 523 (lambda ()
528 (mpc--status-callback) 524 (mpc--status-callback)
@@ -604,7 +600,7 @@ The songs are returned as alists."
604 (cond 600 (cond
605 ((eq tag 'Playlist) 601 ((eq tag 'Playlist)
606 ;; Special case for pseudo-tag playlist. 602 ;; Special case for pseudo-tag playlist.
607 (let ((l (condition-case err 603 (let ((l (condition-case nil
608 (mpc-proc-buf-to-alists 604 (mpc-proc-buf-to-alists
609 (mpc-proc-cmd (list "listplaylistinfo" value))) 605 (mpc-proc-cmd (list "listplaylistinfo" value)))
610 (mpc-proc-error 606 (mpc-proc-error
@@ -637,7 +633,7 @@ The songs are returned as alists."
637 (mpc-union (mpc-cmd-find tag1 value) 633 (mpc-union (mpc-cmd-find tag1 value)
638 (mpc-cmd-find tag2 value)))) 634 (mpc-cmd-find tag2 value))))
639 (t 635 (t
640 (condition-case err 636 (condition-case nil
641 (mpc-proc-buf-to-alists 637 (mpc-proc-buf-to-alists
642 (mpc-proc-cmd (list "find" (symbol-name tag) value))) 638 (mpc-proc-cmd (list "find" (symbol-name tag) value)))
643 (mpc-proc-error 639 (mpc-proc-error
@@ -775,7 +771,7 @@ The songs are returned as alists."
775 771
776(defun mpc-cmd-pause (&optional arg callback) 772(defun mpc-cmd-pause (&optional arg callback)
777 "Pause or resume playback of the queue of songs." 773 "Pause or resume playback of the queue of songs."
778 (lexical-let ((cb callback)) 774 (let ((cb callback))
779 (mpc-proc-cmd (list "pause" arg) 775 (mpc-proc-cmd (list "pause" arg)
780 (lambda () (mpc-status-refresh) (if cb (funcall cb)))) 776 (lambda () (mpc-status-refresh) (if cb (funcall cb))))
781 (unless callback (mpc-proc-sync)))) 777 (unless callback (mpc-proc-sync))))
@@ -839,7 +835,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
839 (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))) 835 (puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
840 836
841(defun mpc-cmd-update (&optional arg callback) 837(defun mpc-cmd-update (&optional arg callback)
842 (lexical-let ((cb callback)) 838 (let ((cb callback))
843 (mpc-proc-cmd (if arg (list "update" arg) "update") 839 (mpc-proc-cmd (if arg (list "update" arg) "update")
844 (lambda () (mpc-status-refresh) (if cb (funcall cb)))) 840 (lambda () (mpc-status-refresh) (if cb (funcall cb))))
845 (unless callback (mpc-proc-sync)))) 841 (unless callback (mpc-proc-sync))))
@@ -939,7 +935,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
939 935
940(defun mpc-tempfiles-clean () 936(defun mpc-tempfiles-clean ()
941 (let ((live ())) 937 (let ((live ()))
942 (maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable) 938 (maphash (lambda (_k v) (push v live)) mpc-tempfiles-reftable)
943 (dolist (f mpc-tempfiles) 939 (dolist (f mpc-tempfiles)
944 (unless (member f live) (ignore-errors (delete-file f)))) 940 (unless (member f live) (ignore-errors (delete-file f))))
945 (setq mpc-tempfiles live))) 941 (setq mpc-tempfiles live)))
@@ -1163,7 +1159,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
1163 (mpc-status-mode)) 1159 (mpc-status-mode))
1164 (mpc-proc-buffer (mpc-proc) 'status buf)) 1160 (mpc-proc-buffer (mpc-proc) 'status buf))
1165 (if (null songs-win) (pop-to-buffer buf) 1161 (if (null songs-win) (pop-to-buffer buf)
1166 (let ((win (split-window songs-win 20 t))) 1162 (let ((_win (split-window songs-win 20 t)))
1167 (set-window-dedicated-p songs-win nil) 1163 (set-window-dedicated-p songs-win nil)
1168 (set-window-buffer songs-win buf) 1164 (set-window-buffer songs-win buf)
1169 (set-window-dedicated-p songs-win 'soft))))) 1165 (set-window-dedicated-p songs-win 'soft)))))
@@ -2351,8 +2347,7 @@ This is used so that they can be compared with `eq', which is needed for
2351 (mpc-proc-cmd (list "seekid" songid time) 2347 (mpc-proc-cmd (list "seekid" songid time)
2352 'mpc-status-refresh)))) 2348 'mpc-status-refresh))))
2353 (let ((status (mpc-cmd-status))) 2349 (let ((status (mpc-cmd-status)))
2354 (lexical-let* ((songid (cdr (assq 'songid status))) 2350 (let* ((songid (cdr (assq 'songid status)))
2355 (step step)
2356 (time (if songid (string-to-number 2351 (time (if songid (string-to-number
2357 (cdr (assq 'time status)))))) 2352 (cdr (assq 'time status))))))
2358 (let ((timer (run-with-timer 2353 (let ((timer (run-with-timer
@@ -2389,17 +2384,14 @@ This is used so that they can be compared with `eq', which is needed for
2389 (if mpc--faster-toggle-timer 2384 (if mpc--faster-toggle-timer
2390 (mpc--faster-stop) 2385 (mpc--faster-stop)
2391 (mpc-status-refresh) (mpc-proc-sync) 2386 (mpc-status-refresh) (mpc-proc-sync)
2392 (lexical-let* ((speedup speedup) 2387 (let* (songid ;The ID of the currently ffwd/rewinding song.
2393 songid ;The ID of the currently ffwd/rewinding song. 2388 songduration ;The duration of that song.
2394 songnb ;The position of that song in the playlist. 2389 songtime ;The time of the song last time we ran.
2395 songduration ;The duration of that song. 2390 oldtime ;The timeoftheday last time we ran.
2396 songtime ;The time of the song last time we ran. 2391 prevsongid) ;The song we're in the process leaving.
2397 oldtime ;The timeoftheday last time we ran.
2398 prevsongid) ;The song we're in the process leaving.
2399 (let ((fun 2392 (let ((fun
2400 (lambda () 2393 (lambda ()
2401 (let ((newsongid (cdr (assq 'songid mpc-status))) 2394 (let ((newsongid (cdr (assq 'songid mpc-status))))
2402 (newsongnb (cdr (assq 'song mpc-status))))
2403 2395
2404 (if (and (equal prevsongid newsongid) 2396 (if (and (equal prevsongid newsongid)
2405 (not (equal prevsongid songid))) 2397 (not (equal prevsongid songid)))
@@ -2450,8 +2442,7 @@ This is used so that they can be compared with `eq', which is needed for
2450 (mpc-proc-cmd 2442 (mpc-proc-cmd
2451 (list "seekid" songid songtime) 2443 (list "seekid" songid songtime)
2452 'mpc-status-refresh) 2444 'mpc-status-refresh)
2453 (mpc-proc-error (mpc-status-refresh))))))) 2445 (mpc-proc-error (mpc-status-refresh)))))))))))
2454 (setq songnb newsongnb)))))
2455 (setq mpc--faster-toggle-forward (> step 0)) 2446 (setq mpc--faster-toggle-forward (> step 0))
2456 (funcall fun) ;Initialize values. 2447 (funcall fun) ;Initialize values.
2457 (setq mpc--faster-toggle-timer 2448 (setq mpc--faster-toggle-timer
@@ -2461,13 +2452,13 @@ This is used so that they can be compared with `eq', which is needed for
2461 2452
2462(defvar mpc-faster-speedup 8) 2453(defvar mpc-faster-speedup 8)
2463 2454
2464(defun mpc-ffwd (event) 2455(defun mpc-ffwd (_event)
2465 "Fast forward." 2456 "Fast forward."
2466 (interactive (list last-nonmenu-event)) 2457 (interactive (list last-nonmenu-event))
2467 ;; (mpc--faster event 4.0 1) 2458 ;; (mpc--faster event 4.0 1)
2468 (mpc--faster-toggle mpc-faster-speedup 1)) 2459 (mpc--faster-toggle mpc-faster-speedup 1))
2469 2460
2470(defun mpc-rewind (event) 2461(defun mpc-rewind (_event)
2471 "Fast rewind." 2462 "Fast rewind."
2472 (interactive (list last-nonmenu-event)) 2463 (interactive (list last-nonmenu-event))
2473 ;; (mpc--faster event 4.0 -1) 2464 ;; (mpc--faster event 4.0 -1)
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index d88b76a7759..d3530b1be3e 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -1,4 +1,4 @@
1;;; newcomment.el --- (un)comment regions of buffers 1;;; newcomment.el --- (un)comment regions of buffers -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1999-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
4 4
@@ -722,7 +722,7 @@ With any other arg, set comment column to indentation of the previous comment
722With prefix ARG, kill comments on that many lines starting with this one." 722With prefix ARG, kill comments on that many lines starting with this one."
723 (interactive "P") 723 (interactive "P")
724 (comment-normalize-vars) 724 (comment-normalize-vars)
725 (dotimes (_ (prefix-numeric-value arg)) 725 (dotimes (i (prefix-numeric-value arg))
726 (save-excursion 726 (save-excursion
727 (beginning-of-line) 727 (beginning-of-line)
728 (let ((cs (comment-search-forward (line-end-position) t))) 728 (let ((cs (comment-search-forward (line-end-position) t)))
diff --git a/lisp/reveal.el b/lisp/reveal.el
index 574c86a0fa4..bf18602379c 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -1,4 +1,4 @@
1;;; reveal.el --- Automatically reveal hidden text at point 1;;; reveal.el --- Automatically reveal hidden text at point -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2000-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
4 4
diff --git a/lisp/server.el b/lisp/server.el
index cb1903ad96c..ce14f133f0a 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1,4 +1,4 @@
1;;; server.el --- Lisp code for GNU Emacs running as server process 1;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc.
4 4
@@ -335,9 +335,9 @@ If CLIENT is non-nil, add a description of it to the logged message."
335 (goto-char (point-max)) 335 (goto-char (point-max))
336 (insert (funcall server-log-time-function) 336 (insert (funcall server-log-time-function)
337 (cond 337 (cond
338 ((null client) " ") 338 ((null client) " ")
339 ((listp client) (format " %s: " (car client))) 339 ((listp client) (format " %s: " (car client)))
340 (t (format " %s: " client))) 340 (t (format " %s: " client)))
341 string) 341 string)
342 (or (bolp) (newline))))) 342 (or (bolp) (newline)))))
343 343
@@ -355,7 +355,7 @@ If CLIENT is non-nil, add a description of it to the logged message."
355 (and (process-contact proc :server) 355 (and (process-contact proc :server)
356 (eq (process-status proc) 'closed) 356 (eq (process-status proc) 'closed)
357 (ignore-errors 357 (ignore-errors
358 (delete-file (process-get proc :server-file)))) 358 (delete-file (process-get proc :server-file))))
359 (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) 359 (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
360 (server-delete-client proc)) 360 (server-delete-client proc))
361 361
@@ -410,18 +410,19 @@ If CLIENT is non-nil, add a description of it to the logged message."
410 proc 410 proc
411 ;; See if this is the last frame for this client. 411 ;; See if this is the last frame for this client.
412 (>= 1 (let ((frame-num 0)) 412 (>= 1 (let ((frame-num 0))
413 (dolist (f (frame-list)) 413 (dolist (f (frame-list))
414 (when (eq proc (frame-parameter f 'client)) 414 (when (eq proc (frame-parameter f 'client))
415 (setq frame-num (1+ frame-num)))) 415 (setq frame-num (1+ frame-num))))
416 frame-num))) 416 frame-num)))
417 (server-log (format "server-handle-delete-frame, frame %s" frame) proc) 417 (server-log (format "server-handle-delete-frame, frame %s" frame) proc)
418 (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. 418 (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
419 419
420(defun server-handle-suspend-tty (terminal) 420(defun server-handle-suspend-tty (terminal)
421 "Notify the emacsclient process to suspend itself when its tty device is suspended." 421 "Notify the client process that its tty device is suspended."
422 (dolist (proc (server-clients-with 'terminal terminal)) 422 (dolist (proc (server-clients-with 'terminal terminal))
423 (server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc) 423 (server-log (format "server-handle-suspend-tty, terminal %s" terminal)
424 (condition-case err 424 proc)
425 (condition-case nil
425 (server-send-string proc "-suspend \n") 426 (server-send-string proc "-suspend \n")
426 (file-error ;The pipe/socket was closed. 427 (file-error ;The pipe/socket was closed.
427 (ignore-errors (server-delete-client proc)))))) 428 (ignore-errors (server-delete-client proc))))))
@@ -540,8 +541,8 @@ To force-start a server, do \\[server-force-delete] and then
540 (if (not (eq t (server-running-p server-name))) 541 (if (not (eq t (server-running-p server-name)))
541 ;; Remove any leftover socket or authentication file 542 ;; Remove any leftover socket or authentication file
542 (ignore-errors 543 (ignore-errors
543 (let (delete-by-moving-to-trash) 544 (let (delete-by-moving-to-trash)
544 (delete-file server-file))) 545 (delete-file server-file)))
545 (setq server-mode nil) ;; already set by the minor mode code 546 (setq server-mode nil) ;; already set by the minor mode code
546 (display-warning 547 (display-warning
547 'server 548 'server
@@ -596,11 +597,11 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
596 (when server-use-tcp 597 (when server-use-tcp
597 (let ((auth-key 598 (let ((auth-key
598 (loop 599 (loop
599 ;; The auth key is a 64-byte string of random chars in the 600 ;; The auth key is a 64-byte string of random chars in the
600 ;; range `!'..`~'. 601 ;; range `!'..`~'.
601 repeat 64 602 repeat 64
602 collect (+ 33 (random 94)) into auth 603 collect (+ 33 (random 94)) into auth
603 finally return (concat auth)))) 604 finally return (concat auth))))
604 (process-put server-process :auth-key auth-key) 605 (process-put server-process :auth-key auth-key)
605 (with-temp-file server-file 606 (with-temp-file server-file
606 (set-buffer-multibyte nil) 607 (set-buffer-multibyte nil)
@@ -695,31 +696,31 @@ Server mode runs a process that accepts commands from the
695 (add-to-list 'frame-inherited-parameters 'client) 696 (add-to-list 'frame-inherited-parameters 'client)
696 (let ((frame 697 (let ((frame
697 (server-with-environment (process-get proc 'env) 698 (server-with-environment (process-get proc 'env)
698 '("LANG" "LC_CTYPE" "LC_ALL" 699 '("LANG" "LC_CTYPE" "LC_ALL"
699 ;; For tgetent(3); list according to ncurses(3). 700 ;; For tgetent(3); list according to ncurses(3).
700 "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" 701 "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
701 "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" 702 "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
702 "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" 703 "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
703 "TERMINFO_DIRS" "TERMPATH" 704 "TERMINFO_DIRS" "TERMPATH"
704 ;; rxvt wants these 705 ;; rxvt wants these
705 "COLORFGBG" "COLORTERM") 706 "COLORFGBG" "COLORTERM")
706 (make-frame `((window-system . nil) 707 (make-frame `((window-system . nil)
707 (tty . ,tty) 708 (tty . ,tty)
708 (tty-type . ,type) 709 (tty-type . ,type)
709 ;; Ignore nowait here; we always need to 710 ;; Ignore nowait here; we always need to
710 ;; clean up opened ttys when the client dies. 711 ;; clean up opened ttys when the client dies.
711 (client . ,proc) 712 (client . ,proc)
712 ;; This is a leftover from an earlier 713 ;; This is a leftover from an earlier
713 ;; attempt at making it possible for process 714 ;; attempt at making it possible for process
714 ;; run in the server process to use the 715 ;; run in the server process to use the
715 ;; environment of the client process. 716 ;; environment of the client process.
716 ;; It has no effect now and to make it work 717 ;; It has no effect now and to make it work
717 ;; we'd need to decide how to make 718 ;; we'd need to decide how to make
718 ;; process-environment interact with client 719 ;; process-environment interact with client
719 ;; envvars, and then to change the 720 ;; envvars, and then to change the
720 ;; C functions `child_setup' and 721 ;; C functions `child_setup' and
721 ;; `getenv_internal' accordingly. 722 ;; `getenv_internal' accordingly.
722 (environment . ,(process-get proc 'env))))))) 723 (environment . ,(process-get proc 'env)))))))
723 724
724 ;; ttys don't use the `display' parameter, but callproc.c does to set 725 ;; ttys don't use the `display' parameter, but callproc.c does to set
725 ;; the DISPLAY environment on subprocesses. 726 ;; the DISPLAY environment on subprocesses.
@@ -783,8 +784,7 @@ Server mode runs a process that accepts commands from the
783 ;; frame because input from that display will be blocked (until exiting 784 ;; frame because input from that display will be blocked (until exiting
784 ;; the minibuffer). Better exit this minibuffer right away. 785 ;; the minibuffer). Better exit this minibuffer right away.
785 ;; Similarly with recursive-edits such as the splash screen. 786 ;; Similarly with recursive-edits such as the splash screen.
786 (run-with-timer 0 nil (lexical-let ((proc proc)) 787 (run-with-timer 0 nil (lambda () (server-execute-continuation proc)))
787 (lambda () (server-execute-continuation proc))))
788 (top-level))) 788 (top-level)))
789 789
790;; We use various special properties on process objects: 790;; We use various special properties on process objects:
@@ -978,7 +978,7 @@ The following commands are accepted by the client:
978 978
979 ;; -resume: Resume a suspended tty frame. 979 ;; -resume: Resume a suspended tty frame.
980 (`"-resume" 980 (`"-resume"
981 (lexical-let ((terminal (process-get proc 'terminal))) 981 (let ((terminal (process-get proc 'terminal)))
982 (setq dontkill t) 982 (setq dontkill t)
983 (push (lambda () 983 (push (lambda ()
984 (when (eq (terminal-live-p terminal) t) 984 (when (eq (terminal-live-p terminal) t)
@@ -989,7 +989,7 @@ The following commands are accepted by the client:
989 ;; get out of sync, and a C-z sends a SIGTSTP to 989 ;; get out of sync, and a C-z sends a SIGTSTP to
990 ;; emacsclient.) 990 ;; emacsclient.)
991 (`"-suspend" 991 (`"-suspend"
992 (lexical-let ((terminal (process-get proc 'terminal))) 992 (let ((terminal (process-get proc 'terminal)))
993 (setq dontkill t) 993 (setq dontkill t)
994 (push (lambda () 994 (push (lambda ()
995 (when (eq (terminal-live-p terminal) t) 995 (when (eq (terminal-live-p terminal) t)
@@ -1036,7 +1036,7 @@ The following commands are accepted by the client:
1036 (`"-eval" 1036 (`"-eval"
1037 (if use-current-frame 1037 (if use-current-frame
1038 (setq use-current-frame 'always)) 1038 (setq use-current-frame 'always))
1039 (lexical-let ((expr (pop args-left))) 1039 (let ((expr (pop args-left)))
1040 (if coding-system 1040 (if coding-system
1041 (setq expr (decode-coding-string expr coding-system))) 1041 (setq expr (decode-coding-string expr coding-system)))
1042 (push (lambda () (server-eval-and-print expr proc)) 1042 (push (lambda () (server-eval-and-print expr proc))
@@ -1081,23 +1081,15 @@ The following commands are accepted by the client:
1081 1081
1082 (process-put 1082 (process-put
1083 proc 'continuation 1083 proc 'continuation
1084 (lexical-let ((proc proc) 1084 (lambda ()
1085 (files files) 1085 (with-current-buffer (get-buffer-create server-buffer)
1086 (nowait nowait) 1086 ;; Use the same cwd as the emacsclient, if possible, so
1087 (commands commands) 1087 ;; relative file names work correctly, even in `eval'.
1088 (dontkill dontkill) 1088 (let ((default-directory
1089 (frame frame) 1089 (if (and dir (file-directory-p dir))
1090 (dir dir) 1090 dir default-directory)))
1091 (tty-name tty-name)) 1091 (server-execute proc files nowait commands
1092 (lambda () 1092 dontkill frame tty-name)))))
1093 (with-current-buffer (get-buffer-create server-buffer)
1094 ;; Use the same cwd as the emacsclient, if possible, so
1095 ;; relative file names work correctly, even in `eval'.
1096 (let ((default-directory
1097 (if (and dir (file-directory-p dir))
1098 dir default-directory)))
1099 (server-execute proc files nowait commands
1100 dontkill frame tty-name))))))
1101 1093
1102 (when (or frame files) 1094 (when (or frame files)
1103 (server-goto-toplevel proc)) 1095 (server-goto-toplevel proc))
@@ -1222,7 +1214,10 @@ so don't mark these buffers specially, just visit them normally."
1222 (process-put proc 'buffers 1214 (process-put proc 'buffers
1223 (nconc (process-get proc 'buffers) client-record))) 1215 (nconc (process-get proc 'buffers) client-record)))
1224 client-record)) 1216 client-record))
1225 1217
1218(defvar server-kill-buffer-running nil
1219 "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
1220
1226(defun server-buffer-done (buffer &optional for-killing) 1221(defun server-buffer-done (buffer &optional for-killing)
1227 "Mark BUFFER as \"done\" for its client(s). 1222 "Mark BUFFER as \"done\" for its client(s).
1228This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED). 1223This buries the buffer, then returns a list of the form (NEXT-BUFFER KILLED).
@@ -1344,9 +1339,6 @@ specifically for the clients and did not exist before their request for it."
1344 (setq live-client t)))) 1339 (setq live-client t))))
1345 (yes-or-no-p "This Emacs session has clients; exit anyway? "))) 1340 (yes-or-no-p "This Emacs session has clients; exit anyway? ")))
1346 1341
1347(defvar server-kill-buffer-running nil
1348 "Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
1349
1350(defun server-kill-buffer () 1342(defun server-kill-buffer ()
1351 "Remove the current buffer from its clients' buffer list. 1343 "Remove the current buffer from its clients' buffer list.
1352Designed to be added to `kill-buffer-hook'." 1344Designed to be added to `kill-buffer-hook'."
@@ -1374,12 +1366,12 @@ If invoked with a prefix argument, or if there is no server process running,
1374starts server process and that is all. Invoked by \\[server-edit]." 1366starts server process and that is all. Invoked by \\[server-edit]."
1375 (interactive "P") 1367 (interactive "P")
1376 (cond 1368 (cond
1377 ((or arg 1369 ((or arg
1378 (not server-process) 1370 (not server-process)
1379 (memq (process-status server-process) '(signal exit))) 1371 (memq (process-status server-process) '(signal exit)))
1380 (server-mode 1)) 1372 (server-mode 1))
1381 (server-clients (apply 'server-switch-buffer (server-done))) 1373 (server-clients (apply 'server-switch-buffer (server-done)))
1382 (t (message "No server editing buffers exist")))) 1374 (t (message "No server editing buffers exist"))))
1383 1375
1384(defun server-switch-buffer (&optional next-buffer killed-one filepos) 1376(defun server-switch-buffer (&optional next-buffer killed-one filepos)
1385 "Switch to another buffer, preferably one that has a client. 1377 "Switch to another buffer, preferably one that has a client.
diff --git a/lisp/simple.el b/lisp/simple.el
index bd7d5da257e..a414fc77a39 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -28,8 +28,7 @@
28 28
29;;; Code: 29;;; Code:
30 30
31;; This is for lexical-let in apply-partially. 31(eval-when-compile (require 'cl)) ;For define-minor-mode.
32(eval-when-compile (require 'cl))
33 32
34(declare-function widget-convert "wid-edit" (type &rest args)) 33(declare-function widget-convert "wid-edit" (type &rest args))
35(declare-function shell-mode "shell" ()) 34(declare-function shell-mode "shell" ())
@@ -1000,7 +999,7 @@ When called interactively, the word count is printed in echo area."
1000 (goto-char (point-min)) 999 (goto-char (point-min))
1001 (while (forward-word 1) 1000 (while (forward-word 1)
1002 (setq count (1+ count))))) 1001 (setq count (1+ count)))))
1003 (if (interactive-p) 1002 (if (called-interactively-p 'interactive)
1004 (message "Region has %d words" count)) 1003 (message "Region has %d words" count))
1005 count)) 1004 count))
1006 1005
@@ -1220,12 +1219,12 @@ this command arranges for all errors to enter the debugger."
1220 current-prefix-arg)) 1219 current-prefix-arg))
1221 1220
1222 (if (null eval-expression-debug-on-error) 1221 (if (null eval-expression-debug-on-error)
1223 (setq values (cons (eval eval-expression-arg) values)) 1222 (push (eval eval-expression-arg lexical-binding) values)
1224 (let ((old-value (make-symbol "t")) new-value) 1223 (let ((old-value (make-symbol "t")) new-value)
1225 ;; Bind debug-on-error to something unique so that we can 1224 ;; Bind debug-on-error to something unique so that we can
1226 ;; detect when evaled code changes it. 1225 ;; detect when evaled code changes it.
1227 (let ((debug-on-error old-value)) 1226 (let ((debug-on-error old-value))
1228 (setq values (cons (eval eval-expression-arg) values)) 1227 (push (eval eval-expression-arg lexical-binding) values)
1229 (setq new-value debug-on-error)) 1228 (setq new-value debug-on-error))
1230 ;; If evaled code has changed the value of debug-on-error, 1229 ;; If evaled code has changed the value of debug-on-error,
1231 ;; propagate that change to the global binding. 1230 ;; propagate that change to the global binding.
@@ -2829,51 +2828,6 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]."
2829 (reset-this-command-lengths) 2828 (reset-this-command-lengths)
2830 (restore-overriding-map)) 2829 (restore-overriding-map))
2831 2830
2832;; This function is here rather than in subr.el because it uses CL.
2833(defmacro with-wrapper-hook (var args &rest body)
2834 "Run BODY wrapped with the VAR hook.
2835VAR is a special hook: its functions are called with a first argument
2836which is the \"original\" code (the BODY), so the hook function can wrap
2837the original function, or call it any number of times (including not calling
2838it at all). This is similar to an `around' advice.
2839VAR is normally a symbol (a variable) in which case it is treated like
2840a hook, with a buffer-local and a global part. But it can also be an
2841arbitrary expression.
2842ARGS is a list of variables which will be passed as additional arguments
2843to each function, after the initial argument, and which the first argument
2844expects to receive when called."
2845 (declare (indent 2) (debug t))
2846 ;; We need those two gensyms because CL's lexical scoping is not available
2847 ;; for function arguments :-(
2848 (let ((funs (make-symbol "funs"))
2849 (global (make-symbol "global"))
2850 (argssym (make-symbol "args")))
2851 ;; Since the hook is a wrapper, the loop has to be done via
2852 ;; recursion: a given hook function will call its parameter in order to
2853 ;; continue looping.
2854 `(labels ((runrestofhook (,funs ,global ,argssym)
2855 ;; `funs' holds the functions left on the hook and `global'
2856 ;; holds the functions left on the global part of the hook
2857 ;; (in case the hook is local).
2858 (lexical-let ((funs ,funs)
2859 (global ,global))
2860 (if (consp funs)
2861 (if (eq t (car funs))
2862 (runrestofhook
2863 (append global (cdr funs)) nil ,argssym)
2864 (apply (car funs)
2865 (lambda (&rest ,argssym)
2866 (runrestofhook (cdr funs) global ,argssym))
2867 ,argssym))
2868 ;; Once there are no more functions on the hook, run
2869 ;; the original body.
2870 (apply (lambda ,args ,@body) ,argssym)))))
2871 (runrestofhook ,var
2872 ;; The global part of the hook, if any.
2873 ,(if (symbolp var)
2874 `(if (local-variable-p ',var)
2875 (default-value ',var)))
2876 (list ,@args)))))
2877 2831
2878(defvar filter-buffer-substring-functions nil 2832(defvar filter-buffer-substring-functions nil
2879 "Wrapper hook around `filter-buffer-substring'. 2833 "Wrapper hook around `filter-buffer-substring'.
@@ -6652,37 +6606,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil."
6652 buffer-invisibility-spec) 6606 buffer-invisibility-spec)
6653 (setq buffer-invisibility-spec nil))) 6607 (setq buffer-invisibility-spec nil)))
6654 6608
6655;; Partial application of functions (similar to "currying").
6656;; This function is here rather than in subr.el because it uses CL.
6657(defun apply-partially (fun &rest args)
6658 "Return a function that is a partial application of FUN to ARGS.
6659ARGS is a list of the first N arguments to pass to FUN.
6660The result is a new function which does the same as FUN, except that
6661the first N arguments are fixed at the values with which this function
6662was called."
6663 (lexical-let ((fun fun) (args1 args))
6664 (lambda (&rest args2) (apply fun (append args1 args2)))))
6665
6666;; Minibuffer prompt stuff. 6609;; Minibuffer prompt stuff.
6667 6610
6668;(defun minibuffer-prompt-modification (start end) 6611;;(defun minibuffer-prompt-modification (start end)
6669; (error "You cannot modify the prompt")) 6612;; (error "You cannot modify the prompt"))
6670; 6613;;
6671; 6614;;
6672;(defun minibuffer-prompt-insertion (start end) 6615;;(defun minibuffer-prompt-insertion (start end)
6673; (let ((inhibit-modification-hooks t)) 6616;; (let ((inhibit-modification-hooks t))
6674; (delete-region start end) 6617;; (delete-region start end)
6675; ;; Discard undo information for the text insertion itself 6618;; ;; Discard undo information for the text insertion itself
6676; ;; and for the text deletion.above. 6619;; ;; and for the text deletion.above.
6677; (when (consp buffer-undo-list) 6620;; (when (consp buffer-undo-list)
6678; (setq buffer-undo-list (cddr buffer-undo-list))) 6621;; (setq buffer-undo-list (cddr buffer-undo-list)))
6679; (message "You cannot modify the prompt"))) 6622;; (message "You cannot modify the prompt")))
6680; 6623;;
6681; 6624;;
6682;(setq minibuffer-prompt-properties 6625;;(setq minibuffer-prompt-properties
6683; (list 'modification-hooks '(minibuffer-prompt-modification) 6626;; (list 'modification-hooks '(minibuffer-prompt-modification)
6684; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) 6627;; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
6685;
6686 6628
6687 6629
6688;;;; Problematic external packages. 6630;;;; Problematic external packages.
diff --git a/lisp/startup.el b/lisp/startup.el
index e8e85a41c77..d2184778212 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1,4 +1,4 @@
1;;; startup.el --- process Emacs shell arguments 1;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc.
4 4
@@ -98,6 +98,7 @@ the remaining command-line args are in the variable `command-line-args-left'.")
98 "List of command-line args not yet processed.") 98 "List of command-line args not yet processed.")
99 99
100(defvaralias 'argv 'command-line-args-left 100(defvaralias 'argv 'command-line-args-left
101 ;; FIXME: Bad name for a dynamically bound variable.
101 "List of command-line args not yet processed. 102 "List of command-line args not yet processed.
102This is a convenience alias, so that one can write \(pop argv\) 103This is a convenience alias, so that one can write \(pop argv\)
103inside of --eval command line arguments in order to access 104inside of --eval command line arguments in order to access
@@ -326,7 +327,7 @@ this variable usefully is to set it while building and dumping Emacs."
326 :type '(choice (const :tag "none" nil) string) 327 :type '(choice (const :tag "none" nil) string)
327 :group 'initialization 328 :group 'initialization
328 :initialize 'custom-initialize-default 329 :initialize 'custom-initialize-default
329 :set (lambda (variable value) 330 :set (lambda (_variable _value)
330 (error "Customizing `site-run-file' does not work"))) 331 (error "Customizing `site-run-file' does not work")))
331 332
332(defcustom mail-host-address nil 333(defcustom mail-host-address nil
@@ -1095,7 +1096,8 @@ the `--debug-init' option to view a complete error backtrace."
1095 user-init-file 1096 user-init-file
1096 (get (car error) 'error-message) 1097 (get (car error) 'error-message)
1097 (if (cdr error) ": " "") 1098 (if (cdr error) ": " "")
1098 (mapconcat (lambda (s) (prin1-to-string s t)) (cdr error) ", ")) 1099 (mapconcat (lambda (s) (prin1-to-string s t))
1100 (cdr error) ", "))
1099 :warning) 1101 :warning)
1100 (setq init-file-had-error t)))) 1102 (setq init-file-had-error t))))
1101 1103
@@ -1291,25 +1293,25 @@ If this is nil, no message will be displayed."
1291;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1293;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1292 1294
1293(defconst fancy-startup-text 1295(defconst fancy-startup-text
1294 '((:face (variable-pitch (:foreground "red")) 1296 `((:face (variable-pitch (:foreground "red"))
1295 "Welcome to " 1297 "Welcome to "
1296 :link ("GNU Emacs" 1298 :link ("GNU Emacs"
1297 (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) 1299 ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
1298 "Browse http://www.gnu.org/software/emacs/") 1300 "Browse http://www.gnu.org/software/emacs/")
1299 ", one component of the " 1301 ", one component of the "
1300 :link 1302 :link
1301 (lambda () 1303 ,(lambda ()
1302 (if (eq system-type 'gnu/linux) 1304 (if (eq system-type 'gnu/linux)
1303 '("GNU/Linux" 1305 `("GNU/Linux"
1304 (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) 1306 ,(lambda (_button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
1305 "Browse http://www.gnu.org/gnu/linux-and-gnu.html") 1307 "Browse http://www.gnu.org/gnu/linux-and-gnu.html")
1306 '("GNU" (lambda (button) (describe-gnu-project)) 1308 `("GNU" ,(lambda (_button) (describe-gnu-project))
1307 "Display info on the GNU project"))) 1309 "Display info on the GNU project")))
1308 " operating system.\n\n" 1310 " operating system.\n\n"
1309 :face variable-pitch 1311 :face variable-pitch
1310 :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) 1312 :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
1311 "\tLearn basic keystroke commands" 1313 "\tLearn basic keystroke commands"
1312 (lambda () 1314 ,(lambda ()
1313 (let* ((en "TUTORIAL") 1315 (let* ((en "TUTORIAL")
1314 (tut (or (get-language-info current-language-environment 1316 (tut (or (get-language-info current-language-environment
1315 'tutorial) 1317 'tutorial)
@@ -1327,19 +1329,20 @@ If this is nil, no message will be displayed."
1327 (concat " (" title ")")))) 1329 (concat " (" title ")"))))
1328 "\n" 1330 "\n"
1329 :link ("Emacs Guided Tour" 1331 :link ("Emacs Guided Tour"
1330 (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) 1332 ,(lambda (_button)
1333 (browse-url "http://www.gnu.org/software/emacs/tour/"))
1331 "Browse http://www.gnu.org/software/emacs/tour/") 1334 "Browse http://www.gnu.org/software/emacs/tour/")
1332 "\tOverview of Emacs features at gnu.org\n" 1335 "\tOverview of Emacs features at gnu.org\n"
1333 :link ("View Emacs Manual" (lambda (button) (info-emacs-manual))) 1336 :link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
1334 "\tView the Emacs manual using Info\n" 1337 "\tView the Emacs manual using Info\n"
1335 :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) 1338 :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
1336 "\tGNU Emacs comes with " 1339 "\tGNU Emacs comes with "
1337 :face (variable-pitch (:slant oblique)) 1340 :face (variable-pitch (:slant oblique))
1338 "ABSOLUTELY NO WARRANTY\n" 1341 "ABSOLUTELY NO WARRANTY\n"
1339 :face variable-pitch 1342 :face variable-pitch
1340 :link ("Copying Conditions" (lambda (button) (describe-copying))) 1343 :link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
1341 "\tConditions for redistributing and changing Emacs\n" 1344 "\tConditions for redistributing and changing Emacs\n"
1342 :link ("Ordering Manuals" (lambda (button) (view-order-manuals))) 1345 :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
1343 "\tPurchasing printed copies of manuals\n" 1346 "\tPurchasing printed copies of manuals\n"
1344 "\n")) 1347 "\n"))
1345 "A list of texts to show in the middle part of splash screens. 1348 "A list of texts to show in the middle part of splash screens.
@@ -1347,61 +1350,62 @@ Each element in the list should be a list of strings or pairs
1347`:face FACE', like `fancy-splash-insert' accepts them.") 1350`:face FACE', like `fancy-splash-insert' accepts them.")
1348 1351
1349(defconst fancy-about-text 1352(defconst fancy-about-text
1350 '((:face (variable-pitch (:foreground "red")) 1353 `((:face (variable-pitch (:foreground "red"))
1351 "This is " 1354 "This is "
1352 :link ("GNU Emacs" 1355 :link ("GNU Emacs"
1353 (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) 1356 ,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
1354 "Browse http://www.gnu.org/software/emacs/") 1357 "Browse http://www.gnu.org/software/emacs/")
1355 ", one component of the " 1358 ", one component of the "
1356 :link 1359 :link
1357 (lambda () 1360 ,(lambda ()
1358 (if (eq system-type 'gnu/linux) 1361 (if (eq system-type 'gnu/linux)
1359 '("GNU/Linux" 1362 `("GNU/Linux"
1360 (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")) 1363 ,(lambda (_button)
1364 (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
1361 "Browse http://www.gnu.org/gnu/linux-and-gnu.html") 1365 "Browse http://www.gnu.org/gnu/linux-and-gnu.html")
1362 '("GNU" (lambda (button) (describe-gnu-project)) 1366 `("GNU" ,(lambda (_button) (describe-gnu-project))
1363 "Display info on the GNU project."))) 1367 "Display info on the GNU project.")))
1364 " operating system.\n" 1368 " operating system.\n"
1365 :face (lambda () 1369 :face ,(lambda ()
1366 (list 'variable-pitch 1370 (list 'variable-pitch
1367 (list :foreground 1371 (list :foreground
1368 (if (eq (frame-parameter nil 'background-mode) 'dark) 1372 (if (eq (frame-parameter nil 'background-mode) 'dark)
1369 "cyan" "darkblue")))) 1373 "cyan" "darkblue"))))
1370 "\n" 1374 "\n"
1371 (lambda () (emacs-version)) 1375 ,(lambda () (emacs-version))
1372 "\n" 1376 "\n"
1373 :face (variable-pitch (:height 0.8)) 1377 :face (variable-pitch (:height 0.8))
1374 (lambda () emacs-copyright) 1378 ,(lambda () emacs-copyright)
1375 "\n\n" 1379 "\n\n"
1376 :face variable-pitch 1380 :face variable-pitch
1377 :link ("Authors" 1381 :link ("Authors"
1378 (lambda (button) 1382 ,(lambda (_button)
1379 (view-file (expand-file-name "AUTHORS" data-directory)) 1383 (view-file (expand-file-name "AUTHORS" data-directory))
1380 (goto-char (point-min)))) 1384 (goto-char (point-min))))
1381 "\tMany people have contributed code included in GNU Emacs\n" 1385 "\tMany people have contributed code included in GNU Emacs\n"
1382 :link ("Contributing" 1386 :link ("Contributing"
1383 (lambda (button) 1387 ,(lambda (_button)
1384 (view-file (expand-file-name "CONTRIBUTE" data-directory)) 1388 (view-file (expand-file-name "CONTRIBUTE" data-directory))
1385 (goto-char (point-min)))) 1389 (goto-char (point-min))))
1386 "\tHow to contribute improvements to Emacs\n" 1390 "\tHow to contribute improvements to Emacs\n"
1387 "\n" 1391 "\n"
1388 :link ("GNU and Freedom" (lambda (button) (describe-gnu-project))) 1392 :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project)))
1389 "\tWhy we developed GNU Emacs, and the GNU operating system\n" 1393 "\tWhy we developed GNU Emacs, and the GNU operating system\n"
1390 :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) 1394 :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
1391 "\tGNU Emacs comes with " 1395 "\tGNU Emacs comes with "
1392 :face (variable-pitch (:slant oblique)) 1396 :face (variable-pitch (:slant oblique))
1393 "ABSOLUTELY NO WARRANTY\n" 1397 "ABSOLUTELY NO WARRANTY\n"
1394 :face variable-pitch 1398 :face variable-pitch
1395 :link ("Copying Conditions" (lambda (button) (describe-copying))) 1399 :link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
1396 "\tConditions for redistributing and changing Emacs\n" 1400 "\tConditions for redistributing and changing Emacs\n"
1397 :link ("Getting New Versions" (lambda (button) (describe-distribution))) 1401 :link ("Getting New Versions" ,(lambda (_button) (describe-distribution)))
1398 "\tHow to obtain the latest version of Emacs\n" 1402 "\tHow to obtain the latest version of Emacs\n"
1399 :link ("Ordering Manuals" (lambda (button) (view-order-manuals))) 1403 :link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
1400 "\tBuying printed manuals from the FSF\n" 1404 "\tBuying printed manuals from the FSF\n"
1401 "\n" 1405 "\n"
1402 :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) 1406 :link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
1403 "\tLearn basic Emacs keystroke commands" 1407 "\tLearn basic Emacs keystroke commands"
1404 (lambda () 1408 ,(lambda ()
1405 (let* ((en "TUTORIAL") 1409 (let* ((en "TUTORIAL")
1406 (tut (or (get-language-info current-language-environment 1410 (tut (or (get-language-info current-language-environment
1407 'tutorial) 1411 'tutorial)
@@ -1419,7 +1423,8 @@ Each element in the list should be a list of strings or pairs
1419 (concat " (" title ")")))) 1423 (concat " (" title ")"))))
1420 "\n" 1424 "\n"
1421 :link ("Emacs Guided Tour" 1425 :link ("Emacs Guided Tour"
1422 (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) 1426 ,(lambda (_button)
1427 (browse-url "http://www.gnu.org/software/emacs/tour/"))
1423 "Browse http://www.gnu.org/software/emacs/tour/") 1428 "Browse http://www.gnu.org/software/emacs/tour/")
1424 "\tSee an overview of Emacs features at gnu.org" 1429 "\tSee an overview of Emacs features at gnu.org"
1425 )) 1430 ))
@@ -1526,7 +1531,7 @@ a face or button specification."
1526 (make-button (prog1 (point) (insert-image img)) (point) 1531 (make-button (prog1 (point) (insert-image img)) (point)
1527 'face 'default 1532 'face 'default
1528 'help-echo "mouse-2, RET: Browse http://www.gnu.org/" 1533 'help-echo "mouse-2, RET: Browse http://www.gnu.org/"
1529 'action (lambda (button) (browse-url "http://www.gnu.org/")) 1534 'action (lambda (_button) (browse-url "http://www.gnu.org/"))
1530 'follow-link t) 1535 'follow-link t)
1531 (insert "\n\n"))))) 1536 (insert "\n\n")))))
1532 1537
@@ -1538,16 +1543,16 @@ a face or button specification."
1538 (fancy-splash-insert 1543 (fancy-splash-insert
1539 :face 'variable-pitch 1544 :face 'variable-pitch
1540 "\nTo start... " 1545 "\nTo start... "
1541 :link '("Open a File" 1546 :link `("Open a File"
1542 (lambda (button) (call-interactively 'find-file)) 1547 ,(lambda (_button) (call-interactively 'find-file))
1543 "Specify a new file's name, to edit the file") 1548 "Specify a new file's name, to edit the file")
1544 " " 1549 " "
1545 :link '("Open Home Directory" 1550 :link `("Open Home Directory"
1546 (lambda (button) (dired "~")) 1551 ,(lambda (_button) (dired "~"))
1547 "Open your home directory, to operate on its files") 1552 "Open your home directory, to operate on its files")
1548 " " 1553 " "
1549 :link '("Customize Startup" 1554 :link `("Customize Startup"
1550 (lambda (button) (customize-group 'initialization)) 1555 ,(lambda (_button) (customize-group 'initialization))
1551 "Change initialization settings including this screen") 1556 "Change initialization settings including this screen")
1552 "\n")) 1557 "\n"))
1553 (fancy-splash-insert 1558 (fancy-splash-insert
@@ -1586,15 +1591,15 @@ a face or button specification."
1586 (when concise 1591 (when concise
1587 (fancy-splash-insert 1592 (fancy-splash-insert
1588 :face 'variable-pitch "\n" 1593 :face 'variable-pitch "\n"
1589 :link '("Dismiss this startup screen" 1594 :link `("Dismiss this startup screen"
1590 (lambda (button) 1595 ,(lambda (_button)
1591 (when startup-screen-inhibit-startup-screen 1596 (when startup-screen-inhibit-startup-screen
1592 (customize-set-variable 'inhibit-startup-screen t) 1597 (customize-set-variable 'inhibit-startup-screen t)
1593 (customize-mark-to-save 'inhibit-startup-screen) 1598 (customize-mark-to-save 'inhibit-startup-screen)
1594 (custom-save-all)) 1599 (custom-save-all))
1595 (let ((w (get-buffer-window "*GNU Emacs*"))) 1600 (let ((w (get-buffer-window "*GNU Emacs*")))
1596 (and w (not (one-window-p)) (delete-window w))) 1601 (and w (not (one-window-p)) (delete-window w)))
1597 (kill-buffer "*GNU Emacs*"))) 1602 (kill-buffer "*GNU Emacs*")))
1598 " ") 1603 " ")
1599 (when (or user-init-file custom-file) 1604 (when (or user-init-file custom-file)
1600 (let ((checked (create-image "checked.xpm" 1605 (let ((checked (create-image "checked.xpm"
@@ -1809,37 +1814,37 @@ To quit a partially entered command, type Control-g.\n")
1809 1814
1810 (insert "\nImportant Help menu items:\n") 1815 (insert "\nImportant Help menu items:\n")
1811 (insert-button "Emacs Tutorial" 1816 (insert-button "Emacs Tutorial"
1812 'action (lambda (button) (help-with-tutorial)) 1817 'action (lambda (_button) (help-with-tutorial))
1813 'follow-link t) 1818 'follow-link t)
1814 (insert "\t\tLearn basic Emacs keystroke commands\n") 1819 (insert "\t\tLearn basic Emacs keystroke commands\n")
1815 (insert-button "Read the Emacs Manual" 1820 (insert-button "Read the Emacs Manual"
1816 'action (lambda (button) (info-emacs-manual)) 1821 'action (lambda (_button) (info-emacs-manual))
1817 'follow-link t) 1822 'follow-link t)
1818 (insert "\tView the Emacs manual using Info\n") 1823 (insert "\tView the Emacs manual using Info\n")
1819 (insert-button "\(Non)Warranty" 1824 (insert-button "\(Non)Warranty"
1820 'action (lambda (button) (describe-no-warranty)) 1825 'action (lambda (_button) (describe-no-warranty))
1821 'follow-link t) 1826 'follow-link t)
1822 (insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") 1827 (insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
1823 (insert-button "Copying Conditions" 1828 (insert-button "Copying Conditions"
1824 'action (lambda (button) (describe-copying)) 1829 'action (lambda (_button) (describe-copying))
1825 'follow-link t) 1830 'follow-link t)
1826 (insert "\tConditions for redistributing and changing Emacs\n") 1831 (insert "\tConditions for redistributing and changing Emacs\n")
1827 (insert-button "More Manuals / Ordering Manuals" 1832 (insert-button "More Manuals / Ordering Manuals"
1828 'action (lambda (button) (view-order-manuals)) 1833 'action (lambda (_button) (view-order-manuals))
1829 'follow-link t) 1834 'follow-link t)
1830 (insert " How to order printed manuals from the FSF\n") 1835 (insert " How to order printed manuals from the FSF\n")
1831 1836
1832 (insert "\nUseful tasks:\n") 1837 (insert "\nUseful tasks:\n")
1833 (insert-button "Visit New File" 1838 (insert-button "Visit New File"
1834 'action (lambda (button) (call-interactively 'find-file)) 1839 'action (lambda (_button) (call-interactively 'find-file))
1835 'follow-link t) 1840 'follow-link t)
1836 (insert "\t\tSpecify a new file's name, to edit the file\n") 1841 (insert "\t\tSpecify a new file's name, to edit the file\n")
1837 (insert-button "Open Home Directory" 1842 (insert-button "Open Home Directory"
1838 'action (lambda (button) (dired "~")) 1843 'action (lambda (_button) (dired "~"))
1839 'follow-link t) 1844 'follow-link t)
1840 (insert "\tOpen your home directory, to operate on its files\n") 1845 (insert "\tOpen your home directory, to operate on its files\n")
1841 (insert-button "Customize Startup" 1846 (insert-button "Customize Startup"
1842 'action (lambda (button) (customize-group 'initialization)) 1847 'action (lambda (_button) (customize-group 'initialization))
1843 'follow-link t) 1848 'follow-link t)
1844 (insert "\tChange initialization settings including this screen\n") 1849 (insert "\tChange initialization settings including this screen\n")
1845 1850
@@ -1873,20 +1878,20 @@ To quit a partially entered command, type Control-g.\n")
1873 (where (key-description where)) 1878 (where (key-description where))
1874 (t "M-x help"))))) 1879 (t "M-x help")))))
1875 (insert-button "Emacs manual" 1880 (insert-button "Emacs manual"
1876 'action (lambda (button) (info-emacs-manual)) 1881 'action (lambda (_button) (info-emacs-manual))
1877 'follow-link t) 1882 'follow-link t)
1878 (insert (substitute-command-keys"\t \\[info-emacs-manual]\t")) 1883 (insert (substitute-command-keys"\t \\[info-emacs-manual]\t"))
1879 (insert-button "Browse manuals" 1884 (insert-button "Browse manuals"
1880 'action (lambda (button) (Info-directory)) 1885 'action (lambda (_button) (Info-directory))
1881 'follow-link t) 1886 'follow-link t)
1882 (insert (substitute-command-keys "\t \\[info]\n")) 1887 (insert (substitute-command-keys "\t \\[info]\n"))
1883 (insert-button "Emacs tutorial" 1888 (insert-button "Emacs tutorial"
1884 'action (lambda (button) (help-with-tutorial)) 1889 'action (lambda (_button) (help-with-tutorial))
1885 'follow-link t) 1890 'follow-link t)
1886 (insert (substitute-command-keys 1891 (insert (substitute-command-keys
1887 "\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n")) 1892 "\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n"))
1888 (insert-button "Buy manuals" 1893 (insert-button "Buy manuals"
1889 'action (lambda (button) (view-order-manuals)) 1894 'action (lambda (_button) (view-order-manuals))
1890 'follow-link t) 1895 'follow-link t)
1891 (insert (substitute-command-keys 1896 (insert (substitute-command-keys
1892 "\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]"))) 1897 "\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]")))
@@ -1894,7 +1899,7 @@ To quit a partially entered command, type Control-g.\n")
1894 ;; Say how to use the menu bar with the keyboard. 1899 ;; Say how to use the menu bar with the keyboard.
1895 (insert "\n") 1900 (insert "\n")
1896 (insert-button "Activate menubar" 1901 (insert-button "Activate menubar"
1897 'action (lambda (button) (tmm-menubar)) 1902 'action (lambda (_button) (tmm-menubar))
1898 'follow-link t) 1903 'follow-link t)
1899 (if (and (eq (key-binding "\M-`") 'tmm-menubar) 1904 (if (and (eq (key-binding "\M-`") 'tmm-menubar)
1900 (eq (key-binding [f10]) 'tmm-menubar)) 1905 (eq (key-binding [f10]) 'tmm-menubar))
@@ -1910,21 +1915,21 @@ If you have no Meta key, you may instead type ESC followed by the character.)")
1910 (insert "\nUseful tasks:\n") 1915 (insert "\nUseful tasks:\n")
1911 1916
1912 (insert-button "Visit New File" 1917 (insert-button "Visit New File"
1913 'action (lambda (button) (call-interactively 'find-file)) 1918 'action (lambda (_button) (call-interactively 'find-file))
1914 'follow-link t) 1919 'follow-link t)
1915 (insert "\t\t\t") 1920 (insert "\t\t\t")
1916 (insert-button "Open Home Directory" 1921 (insert-button "Open Home Directory"
1917 'action (lambda (button) (dired "~")) 1922 'action (lambda (_button) (dired "~"))
1918 'follow-link t) 1923 'follow-link t)
1919 (insert "\n") 1924 (insert "\n")
1920 1925
1921 (insert-button "Customize Startup" 1926 (insert-button "Customize Startup"
1922 'action (lambda (button) (customize-group 'initialization)) 1927 'action (lambda (_button) (customize-group 'initialization))
1923 'follow-link t) 1928 'follow-link t)
1924 (insert "\t\t") 1929 (insert "\t\t")
1925 (insert-button "Open *scratch* buffer" 1930 (insert-button "Open *scratch* buffer"
1926 'action (lambda (button) (switch-to-buffer 1931 'action (lambda (_button) (switch-to-buffer
1927 (get-buffer-create "*scratch*"))) 1932 (get-buffer-create "*scratch*")))
1928 'follow-link t) 1933 'follow-link t)
1929 (insert "\n") 1934 (insert "\n")
1930 (insert "\n" (emacs-version) "\n" emacs-copyright "\n") 1935 (insert "\n" (emacs-version) "\n" emacs-copyright "\n")
@@ -1937,36 +1942,36 @@ If you have no Meta key, you may instead type ESC followed by the character.)")
1937 " 1942 "
1938GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ") 1943GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ")
1939 (insert-button "full details" 1944 (insert-button "full details"
1940 'action (lambda (button) (describe-no-warranty)) 1945 'action (lambda (_button) (describe-no-warranty))
1941 'follow-link t) 1946 'follow-link t)
1942 (insert ". 1947 (insert ".
1943Emacs is Free Software--Free as in Freedom--so you can redistribute copies 1948Emacs is Free Software--Free as in Freedom--so you can redistribute copies
1944of Emacs and modify it; type C-h C-c to see ") 1949of Emacs and modify it; type C-h C-c to see ")
1945 (insert-button "the conditions" 1950 (insert-button "the conditions"
1946 'action (lambda (button) (describe-copying)) 1951 'action (lambda (_button) (describe-copying))
1947 'follow-link t) 1952 'follow-link t)
1948 (insert ". 1953 (insert ".
1949Type C-h C-d for information on ") 1954Type C-h C-d for information on ")
1950 (insert-button "getting the latest version" 1955 (insert-button "getting the latest version"
1951 'action (lambda (button) (describe-distribution)) 1956 'action (lambda (_button) (describe-distribution))
1952 'follow-link t) 1957 'follow-link t)
1953 (insert ".")) 1958 (insert "."))
1954 (insert (substitute-command-keys 1959 (insert (substitute-command-keys
1955 " 1960 "
1956GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) 1961GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for "))
1957 (insert-button "full details" 1962 (insert-button "full details"
1958 'action (lambda (button) (describe-no-warranty)) 1963 'action (lambda (_button) (describe-no-warranty))
1959 'follow-link t) 1964 'follow-link t)
1960 (insert (substitute-command-keys ". 1965 (insert (substitute-command-keys ".
1961Emacs is Free Software--Free as in Freedom--so you can redistribute copies 1966Emacs is Free Software--Free as in Freedom--so you can redistribute copies
1962of Emacs and modify it; type \\[describe-copying] to see ")) 1967of Emacs and modify it; type \\[describe-copying] to see "))
1963 (insert-button "the conditions" 1968 (insert-button "the conditions"
1964 'action (lambda (button) (describe-copying)) 1969 'action (lambda (_button) (describe-copying))
1965 'follow-link t) 1970 'follow-link t)
1966 (insert (substitute-command-keys". 1971 (insert (substitute-command-keys".
1967Type \\[describe-distribution] for information on ")) 1972Type \\[describe-distribution] for information on "))
1968 (insert-button "getting the latest version" 1973 (insert-button "getting the latest version"
1969 'action (lambda (button) (describe-distribution)) 1974 'action (lambda (_button) (describe-distribution))
1970 'follow-link t) 1975 'follow-link t)
1971 (insert "."))) 1976 (insert ".")))
1972 1977
@@ -1977,7 +1982,7 @@ Type \\[describe-distribution] for information on "))
1977 1982
1978 (insert-button "Authors" 1983 (insert-button "Authors"
1979 'action 1984 'action
1980 (lambda (button) 1985 (lambda (_button)
1981 (view-file (expand-file-name "AUTHORS" data-directory)) 1986 (view-file (expand-file-name "AUTHORS" data-directory))
1982 (goto-char (point-min))) 1987 (goto-char (point-min)))
1983 'follow-link t) 1988 'follow-link t)
@@ -1985,34 +1990,34 @@ Type \\[describe-distribution] for information on "))
1985 1990
1986 (insert-button "Contributing" 1991 (insert-button "Contributing"
1987 'action 1992 'action
1988 (lambda (button) 1993 (lambda (_button)
1989 (view-file (expand-file-name "CONTRIBUTE" data-directory)) 1994 (view-file (expand-file-name "CONTRIBUTE" data-directory))
1990 (goto-char (point-min))) 1995 (goto-char (point-min)))
1991 'follow-link t) 1996 'follow-link t)
1992 (insert "\tHow to contribute improvements to Emacs\n\n") 1997 (insert "\tHow to contribute improvements to Emacs\n\n")
1993 1998
1994 (insert-button "GNU and Freedom" 1999 (insert-button "GNU and Freedom"
1995 'action (lambda (button) (describe-gnu-project)) 2000 'action (lambda (_button) (describe-gnu-project))
1996 'follow-link t) 2001 'follow-link t)
1997 (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") 2002 (insert "\t\tWhy we developed GNU Emacs and the GNU system\n")
1998 2003
1999 (insert-button "Absence of Warranty" 2004 (insert-button "Absence of Warranty"
2000 'action (lambda (button) (describe-no-warranty)) 2005 'action (lambda (_button) (describe-no-warranty))
2001 'follow-link t) 2006 'follow-link t)
2002 (insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") 2007 (insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
2003 2008
2004 (insert-button "Copying Conditions" 2009 (insert-button "Copying Conditions"
2005 'action (lambda (button) (describe-copying)) 2010 'action (lambda (_button) (describe-copying))
2006 'follow-link t) 2011 'follow-link t)
2007 (insert "\tConditions for redistributing and changing Emacs\n") 2012 (insert "\tConditions for redistributing and changing Emacs\n")
2008 2013
2009 (insert-button "Getting New Versions" 2014 (insert-button "Getting New Versions"
2010 'action (lambda (button) (describe-distribution)) 2015 'action (lambda (_button) (describe-distribution))
2011 'follow-link t) 2016 'follow-link t)
2012 (insert "\tHow to get the latest version of GNU Emacs\n") 2017 (insert "\tHow to get the latest version of GNU Emacs\n")
2013 2018
2014 (insert-button "More Manuals / Ordering Manuals" 2019 (insert-button "More Manuals / Ordering Manuals"
2015 'action (lambda (button) (view-order-manuals)) 2020 'action (lambda (_button) (view-order-manuals))
2016 'follow-link t) 2021 'follow-link t)
2017 (insert "\tBuying printed manuals from the FSF\n")) 2022 (insert "\tBuying printed manuals from the FSF\n"))
2018 2023
@@ -2078,7 +2083,7 @@ A fancy display is used on graphic displays, normal otherwise."
2078(defalias 'about-emacs 'display-about-screen) 2083(defalias 'about-emacs 'display-about-screen)
2079(defalias 'display-splash-screen 'display-startup-screen) 2084(defalias 'display-splash-screen 'display-startup-screen)
2080 2085
2081(defun command-line-1 (command-line-args-left) 2086(defun command-line-1 (args-left)
2082 (display-startup-echo-area-message) 2087 (display-startup-echo-area-message)
2083 (when (and pure-space-overflow 2088 (when (and pure-space-overflow
2084 (not noninteractive)) 2089 (not noninteractive))
@@ -2089,14 +2094,12 @@ A fancy display is used on graphic displays, normal otherwise."
2089 :warning)) 2094 :warning))
2090 2095
2091 (let ((file-count 0) 2096 (let ((file-count 0)
2097 (command-line-args-left args-left)
2092 first-file-buffer) 2098 first-file-buffer)
2093 (when command-line-args-left 2099 (when command-line-args-left
2094 ;; We have command args; process them. 2100 ;; We have command args; process them.
2095 ;; Note that any local variables in this function affect the 2101 (let ((dir command-line-default-directory)
2096 ;; ability of -f batch-byte-compile to detect free variables. 2102 tem
2097 ;; So we give some of them with common names a cl1- prefix.
2098 (let ((cl1-dir command-line-default-directory)
2099 cl1-tem
2100 ;; This approach loses for "-batch -L DIR --eval "(require foo)", 2103 ;; This approach loses for "-batch -L DIR --eval "(require foo)",
2101 ;; if foo is intended to be found in DIR. 2104 ;; if foo is intended to be found in DIR.
2102 ;; 2105 ;;
@@ -2119,8 +2122,8 @@ A fancy display is used on graphic displays, normal otherwise."
2119 "--find-file" "--visit" "--file" "--no-desktop") 2122 "--find-file" "--visit" "--file" "--no-desktop")
2120 (mapcar (lambda (elt) (concat "-" (car elt))) 2123 (mapcar (lambda (elt) (concat "-" (car elt)))
2121 command-switch-alist))) 2124 command-switch-alist)))
2122 (cl1-line 0) 2125 (line 0)
2123 (cl1-column 0)) 2126 (column 0))
2124 2127
2125 ;; Add the long X options to longopts. 2128 ;; Add the long X options to longopts.
2126 (dolist (tem command-line-x-option-alist) 2129 (dolist (tem command-line-x-option-alist)
@@ -2161,12 +2164,12 @@ A fancy display is used on graphic displays, normal otherwise."
2161 argi orig-argi))))) 2164 argi orig-argi)))))
2162 2165
2163 ;; Execute the option. 2166 ;; Execute the option.
2164 (cond ((setq cl1-tem (assoc argi command-switch-alist)) 2167 (cond ((setq tem (assoc argi command-switch-alist))
2165 (if argval 2168 (if argval
2166 (let ((command-line-args-left 2169 (let ((command-line-args-left
2167 (cons argval command-line-args-left))) 2170 (cons argval command-line-args-left)))
2168 (funcall (cdr cl1-tem) argi)) 2171 (funcall (cdr tem) argi))
2169 (funcall (cdr cl1-tem) argi))) 2172 (funcall (cdr tem) argi)))
2170 2173
2171 ((equal argi "-no-splash") 2174 ((equal argi "-no-splash")
2172 (setq inhibit-startup-screen t)) 2175 (setq inhibit-startup-screen t))
@@ -2175,22 +2178,22 @@ A fancy display is used on graphic displays, normal otherwise."
2175 "-funcall" 2178 "-funcall"
2176 "-e")) ; what the source used to say 2179 "-e")) ; what the source used to say
2177 (setq inhibit-startup-screen t) 2180 (setq inhibit-startup-screen t)
2178 (setq cl1-tem (intern (or argval (pop command-line-args-left)))) 2181 (setq tem (intern (or argval (pop command-line-args-left))))
2179 (if (commandp cl1-tem) 2182 (if (commandp tem)
2180 (command-execute cl1-tem) 2183 (command-execute tem)
2181 (funcall cl1-tem))) 2184 (funcall tem)))
2182 2185
2183 ((member argi '("-eval" "-execute")) 2186 ((member argi '("-eval" "-execute"))
2184 (setq inhibit-startup-screen t) 2187 (setq inhibit-startup-screen t)
2185 (eval (read (or argval (pop command-line-args-left))))) 2188 (eval (read (or argval (pop command-line-args-left)))))
2186 2189
2187 ((member argi '("-L" "-directory")) 2190 ((member argi '("-L" "-directory"))
2188 (setq cl1-tem (expand-file-name 2191 (setq tem (expand-file-name
2189 (command-line-normalize-file-name 2192 (command-line-normalize-file-name
2190 (or argval (pop command-line-args-left))))) 2193 (or argval (pop command-line-args-left)))))
2191 (cond (splice (setcdr splice (cons cl1-tem (cdr splice))) 2194 (cond (splice (setcdr splice (cons tem (cdr splice)))
2192 (setq splice (cdr splice))) 2195 (setq splice (cdr splice)))
2193 (t (setq load-path (cons cl1-tem load-path) 2196 (t (setq load-path (cons tem load-path)
2194 splice load-path)))) 2197 splice load-path))))
2195 2198
2196 ((member argi '("-l" "-load")) 2199 ((member argi '("-l" "-load"))
@@ -2214,10 +2217,10 @@ A fancy display is used on graphic displays, normal otherwise."
2214 2217
2215 ((equal argi "-insert") 2218 ((equal argi "-insert")
2216 (setq inhibit-startup-screen t) 2219 (setq inhibit-startup-screen t)
2217 (setq cl1-tem (or argval (pop command-line-args-left))) 2220 (setq tem (or argval (pop command-line-args-left)))
2218 (or (stringp cl1-tem) 2221 (or (stringp tem)
2219 (error "File name omitted from `-insert' option")) 2222 (error "File name omitted from `-insert' option"))
2220 (insert-file-contents (command-line-normalize-file-name cl1-tem))) 2223 (insert-file-contents (command-line-normalize-file-name tem)))
2221 2224
2222 ((equal argi "-kill") 2225 ((equal argi "-kill")
2223 (kill-emacs t)) 2226 (kill-emacs t))
@@ -2230,42 +2233,42 @@ A fancy display is used on graphic displays, normal otherwise."
2230 (message "\"--no-desktop\" ignored because the Desktop package is not loaded")) 2233 (message "\"--no-desktop\" ignored because the Desktop package is not loaded"))
2231 2234
2232 ((string-match "^\\+[0-9]+\\'" argi) 2235 ((string-match "^\\+[0-9]+\\'" argi)
2233 (setq cl1-line (string-to-number argi))) 2236 (setq line (string-to-number argi)))
2234 2237
2235 ((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi) 2238 ((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi)
2236 (setq cl1-line (string-to-number (match-string 1 argi)) 2239 (setq line (string-to-number (match-string 1 argi))
2237 cl1-column (string-to-number (match-string 2 argi)))) 2240 column (string-to-number (match-string 2 argi))))
2238 2241
2239 ((setq cl1-tem (assoc orig-argi command-line-x-option-alist)) 2242 ((setq tem (assoc orig-argi command-line-x-option-alist))
2240 ;; Ignore X-windows options and their args if not using X. 2243 ;; Ignore X-windows options and their args if not using X.
2241 (setq command-line-args-left 2244 (setq command-line-args-left
2242 (nthcdr (nth 1 cl1-tem) command-line-args-left))) 2245 (nthcdr (nth 1 tem) command-line-args-left)))
2243 2246
2244 ((setq cl1-tem (assoc orig-argi command-line-ns-option-alist)) 2247 ((setq tem (assoc orig-argi command-line-ns-option-alist))
2245 ;; Ignore NS-windows options and their args if not using NS. 2248 ;; Ignore NS-windows options and their args if not using NS.
2246 (setq command-line-args-left 2249 (setq command-line-args-left
2247 (nthcdr (nth 1 cl1-tem) command-line-args-left))) 2250 (nthcdr (nth 1 tem) command-line-args-left)))
2248 2251
2249 ((member argi '("-find-file" "-file" "-visit")) 2252 ((member argi '("-find-file" "-file" "-visit"))
2250 (setq inhibit-startup-screen t) 2253 (setq inhibit-startup-screen t)
2251 ;; An explicit option to specify visiting a file. 2254 ;; An explicit option to specify visiting a file.
2252 (setq cl1-tem (or argval (pop command-line-args-left))) 2255 (setq tem (or argval (pop command-line-args-left)))
2253 (unless (stringp cl1-tem) 2256 (unless (stringp tem)
2254 (error "File name omitted from `%s' option" argi)) 2257 (error "File name omitted from `%s' option" argi))
2255 (setq file-count (1+ file-count)) 2258 (setq file-count (1+ file-count))
2256 (let ((file (expand-file-name 2259 (let ((file (expand-file-name
2257 (command-line-normalize-file-name cl1-tem) 2260 (command-line-normalize-file-name tem)
2258 cl1-dir))) 2261 dir)))
2259 (if (= file-count 1) 2262 (if (= file-count 1)
2260 (setq first-file-buffer (find-file file)) 2263 (setq first-file-buffer (find-file file))
2261 (find-file-other-window file))) 2264 (find-file-other-window file)))
2262 (unless (zerop cl1-line) 2265 (unless (zerop line)
2263 (goto-char (point-min)) 2266 (goto-char (point-min))
2264 (forward-line (1- cl1-line))) 2267 (forward-line (1- line)))
2265 (setq cl1-line 0) 2268 (setq line 0)
2266 (unless (< cl1-column 1) 2269 (unless (< column 1)
2267 (move-to-column (1- cl1-column))) 2270 (move-to-column (1- column)))
2268 (setq cl1-column 0)) 2271 (setq column 0))
2269 2272
2270 ;; These command lines now have no effect. 2273 ;; These command lines now have no effect.
2271 ((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi) 2274 ((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi)
@@ -2293,19 +2296,19 @@ A fancy display is used on graphic displays, normal otherwise."
2293 (let ((file 2296 (let ((file
2294 (expand-file-name 2297 (expand-file-name
2295 (command-line-normalize-file-name orig-argi) 2298 (command-line-normalize-file-name orig-argi)
2296 cl1-dir))) 2299 dir)))
2297 (cond ((= file-count 1) 2300 (cond ((= file-count 1)
2298 (setq first-file-buffer (find-file file))) 2301 (setq first-file-buffer (find-file file)))
2299 (inhibit-startup-screen 2302 (inhibit-startup-screen
2300 (find-file-other-window file)) 2303 (find-file-other-window file))
2301 (t (find-file file)))) 2304 (t (find-file file))))
2302 (unless (zerop cl1-line) 2305 (unless (zerop line)
2303 (goto-char (point-min)) 2306 (goto-char (point-min))
2304 (forward-line (1- cl1-line))) 2307 (forward-line (1- line)))
2305 (setq cl1-line 0) 2308 (setq line 0)
2306 (unless (< cl1-column 1) 2309 (unless (< column 1)
2307 (move-to-column (1- cl1-column))) 2310 (move-to-column (1- column)))
2308 (setq cl1-column 0)))))) 2311 (setq column 0))))))
2309 ;; In unusual circumstances, the execution of Lisp code due 2312 ;; In unusual circumstances, the execution of Lisp code due
2310 ;; to command-line options can cause the last visible frame 2313 ;; to command-line options can cause the last visible frame
2311 ;; to be deleted. In this case, kill emacs to avoid an 2314 ;; to be deleted. In this case, kill emacs to avoid an
diff --git a/lisp/subr.el b/lisp/subr.el
index 8ea4becdc11..e6e0c62e0b4 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions.
116 ;; depend on backquote.el. 116 ;; depend on backquote.el.
117 (list 'function (cons 'lambda cdr))) 117 (list 'function (cons 'lambda cdr)))
118 118
119;; Partial application of functions (similar to "currying").
120;; This function is here rather than in subr.el because it uses CL.
121(defun apply-partially (fun &rest args)
122 "Return a function that is a partial application of FUN to ARGS.
123ARGS is a list of the first N arguments to pass to FUN.
124The result is a new function which does the same as FUN, except that
125the first N arguments are fixed at the values with which this function
126was called."
127 `(closure (t) (&rest args)
128 (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
129
119(if (null (featurep 'cl)) 130(if (null (featurep 'cl))
120 (progn 131 (progn
121 ;; If we reload subr.el after having loaded CL, be careful not to 132 ;; If we reload subr.el after having loaded CL, be careful not to
@@ -163,8 +174,6 @@ value of last one, or nil if there are none.
163 ;; If we reload subr.el after having loaded CL, be careful not to 174 ;; If we reload subr.el after having loaded CL, be careful not to
164 ;; overwrite CL's extended definition of `dolist', `dotimes', 175 ;; overwrite CL's extended definition of `dolist', `dotimes',
165 ;; `declare', `push' and `pop'. 176 ;; `declare', `push' and `pop'.
166(defvar --dolist-tail-- nil
167 "Temporary variable used in `dolist' expansion.")
168 177
169(defmacro dolist (spec &rest body) 178(defmacro dolist (spec &rest body)
170 "Loop over a list. 179 "Loop over a list.
@@ -176,18 +185,29 @@ Then evaluate RESULT to get return value, default nil.
176 ;; It would be cleaner to create an uninterned symbol, 185 ;; It would be cleaner to create an uninterned symbol,
177 ;; but that uses a lot more space when many functions in many files 186 ;; but that uses a lot more space when many functions in many files
178 ;; use dolist. 187 ;; use dolist.
188 ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
179 (let ((temp '--dolist-tail--)) 189 (let ((temp '--dolist-tail--))
180 `(let ((,temp ,(nth 1 spec)) 190 ;; This is not a reliable test, but it does not matter because both
181 ,(car spec)) 191 ;; semantics are acceptable, tho one is slightly faster with dynamic
182 (while ,temp 192 ;; scoping and the other is slightly faster (and has cleaner semantics)
183 (setq ,(car spec) (car ,temp)) 193 ;; with lexical scoping.
184 ,@body 194 (if lexical-binding
185 (setq ,temp (cdr ,temp))) 195 `(let ((,temp ,(nth 1 spec)))
186 ,@(if (cdr (cdr spec)) 196 (while ,temp
187 `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))) 197 (let ((,(car spec) (car ,temp)))
188 198 ,@body
189(defvar --dotimes-limit-- nil 199 (setq ,temp (cdr ,temp))))
190 "Temporary variable used in `dotimes' expansion.") 200 ,@(if (cdr (cdr spec))
201 ;; FIXME: This let often leads to "unused var" warnings.
202 `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
203 `(let ((,temp ,(nth 1 spec))
204 ,(car spec))
205 (while ,temp
206 (setq ,(car spec) (car ,temp))
207 ,@body
208 (setq ,temp (cdr ,temp)))
209 ,@(if (cdr (cdr spec))
210 `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
191 211
192(defmacro dotimes (spec &rest body) 212(defmacro dotimes (spec &rest body)
193 "Loop a certain number of times. 213 "Loop a certain number of times.
@@ -200,15 +220,30 @@ the return value (nil if RESULT is omitted).
200 ;; It would be cleaner to create an uninterned symbol, 220 ;; It would be cleaner to create an uninterned symbol,
201 ;; but that uses a lot more space when many functions in many files 221 ;; but that uses a lot more space when many functions in many files
202 ;; use dotimes. 222 ;; use dotimes.
223 ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
203 (let ((temp '--dotimes-limit--) 224 (let ((temp '--dotimes-limit--)
204 (start 0) 225 (start 0)
205 (end (nth 1 spec))) 226 (end (nth 1 spec)))
206 `(let ((,temp ,end) 227 ;; This is not a reliable test, but it does not matter because both
207 (,(car spec) ,start)) 228 ;; semantics are acceptable, tho one is slightly faster with dynamic
208 (while (< ,(car spec) ,temp) 229 ;; scoping and the other has cleaner semantics.
209 ,@body 230 (if lexical-binding
210 (setq ,(car spec) (1+ ,(car spec)))) 231 (let ((counter '--dotimes-counter--))
211 ,@(cdr (cdr spec))))) 232 `(let ((,temp ,end)
233 (,counter ,start))
234 (while (< ,counter ,temp)
235 (let ((,(car spec) ,counter))
236 ,@body)
237 (setq ,counter (1+ ,counter)))
238 ,@(if (cddr spec)
239 ;; FIXME: This let often leads to "unused var" warnings.
240 `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
241 `(let ((,temp ,end)
242 (,(car spec) ,start))
243 (while (< ,(car spec) ,temp)
244 ,@body
245 (setq ,(car spec) (1+ ,(car spec))))
246 ,@(cdr (cdr spec))))))
212 247
213(defmacro declare (&rest specs) 248(defmacro declare (&rest specs)
214 "Do not evaluate any arguments and return nil. 249 "Do not evaluate any arguments and return nil.
@@ -249,20 +284,6 @@ Any list whose car is `frame-configuration' is assumed to be a frame
249configuration." 284configuration."
250 (and (consp object) 285 (and (consp object)
251 (eq (car object) 'frame-configuration))) 286 (eq (car object) 'frame-configuration)))
252
253(defun functionp (object)
254 "Non-nil if OBJECT is a function."
255 (or (and (symbolp object) (fboundp object)
256 (condition-case nil
257 (setq object (indirect-function object))
258 (error nil))
259 (eq (car-safe object) 'autoload)
260 (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
261 (and (subrp object)
262 ;; Filter out special forms.
263 (not (eq 'unevalled (cdr (subr-arity object)))))
264 (byte-code-function-p object)
265 (eq (car-safe object) 'lambda)))
266 287
267;;;; List functions. 288;;;; List functions.
268 289
@@ -1258,6 +1279,67 @@ the hook's buffer-local value rather than its default value."
1258 (kill-local-variable hook) 1279 (kill-local-variable hook)
1259 (set hook hook-value)))))) 1280 (set hook hook-value))))))
1260 1281
1282(defmacro letrec (binders &rest body)
1283 "Bind variables according to BINDERS then eval BODY.
1284The value of the last form in BODY is returned.
1285Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds
1286SYMBOL to the value of VALUEFORM.
1287All symbols are bound before the VALUEFORMs are evalled."
1288 ;; Only useful in lexical-binding mode.
1289 ;; As a special-form, we could implement it more efficiently (and cleanly,
1290 ;; making the vars actually unbound during evaluation of the binders).
1291 (declare (debug let) (indent 1))
1292 `(let ,(mapcar #'car binders)
1293 ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
1294 ,@body))
1295
1296(defmacro with-wrapper-hook (var args &rest body)
1297 "Run BODY wrapped with the VAR hook.
1298VAR is a special hook: its functions are called with a first argument
1299which is the \"original\" code (the BODY), so the hook function can wrap
1300the original function, or call it any number of times (including not calling
1301it at all). This is similar to an `around' advice.
1302VAR is normally a symbol (a variable) in which case it is treated like
1303a hook, with a buffer-local and a global part. But it can also be an
1304arbitrary expression.
1305ARGS is a list of variables which will be passed as additional arguments
1306to each function, after the initial argument, and which the first argument
1307expects to receive when called."
1308 (declare (indent 2) (debug t))
1309 ;; We need those two gensyms because CL's lexical scoping is not available
1310 ;; for function arguments :-(
1311 (let ((funs (make-symbol "funs"))
1312 (global (make-symbol "global"))
1313 (argssym (make-symbol "args"))
1314 (runrestofhook (make-symbol "runrestofhook")))
1315 ;; Since the hook is a wrapper, the loop has to be done via
1316 ;; recursion: a given hook function will call its parameter in order to
1317 ;; continue looping.
1318 `(letrec ((,runrestofhook
1319 (lambda (,funs ,global ,argssym)
1320 ;; `funs' holds the functions left on the hook and `global'
1321 ;; holds the functions left on the global part of the hook
1322 ;; (in case the hook is local).
1323 (if (consp ,funs)
1324 (if (eq t (car ,funs))
1325 (funcall ,runrestofhook
1326 (append ,global (cdr ,funs)) nil ,argssym)
1327 (apply (car ,funs)
1328 (apply-partially
1329 (lambda (,funs ,global &rest ,argssym)
1330 (funcall ,runrestofhook ,funs ,global ,argssym))
1331 (cdr ,funs) ,global)
1332 ,argssym))
1333 ;; Once there are no more functions on the hook, run
1334 ;; the original body.
1335 (apply (lambda ,args ,@body) ,argssym)))))
1336 (funcall ,runrestofhook ,var
1337 ;; The global part of the hook, if any.
1338 ,(if (symbolp var)
1339 `(if (local-variable-p ',var)
1340 (default-value ',var)))
1341 (list ,@args)))))
1342
1261(defun add-to-list (list-var element &optional append compare-fn) 1343(defun add-to-list (list-var element &optional append compare-fn)
1262 "Add ELEMENT to the value of LIST-VAR if it isn't there yet. 1344 "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
1263The test for presence of ELEMENT is done with `equal', 1345The test for presence of ELEMENT is done with `equal',
@@ -1630,6 +1712,8 @@ This function makes or adds to an entry on `after-load-alist'."
1630 (unless elt 1712 (unless elt
1631 (setq elt (list regexp-or-feature)) 1713 (setq elt (list regexp-or-feature))
1632 (push elt after-load-alist)) 1714 (push elt after-load-alist))
1715 ;; Make sure `form' is evalled in the current lexical/dynamic code.
1716 (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
1633 (when (symbolp regexp-or-feature) 1717 (when (symbolp regexp-or-feature)
1634 ;; For features, the after-load-alist elements get run when `provide' is 1718 ;; For features, the after-load-alist elements get run when `provide' is
1635 ;; called rather than at the end of the file. So add an indirection to 1719 ;; called rather than at the end of the file. So add an indirection to
@@ -2763,6 +2847,71 @@ nor the buffer list."
2763 (when (buffer-live-p ,old-buffer) 2847 (when (buffer-live-p ,old-buffer)
2764 (set-buffer ,old-buffer)))))) 2848 (set-buffer ,old-buffer))))))
2765 2849
2850(defmacro save-window-excursion (&rest body)
2851 "Execute BODY, preserving window sizes and contents.
2852Return the value of the last form in BODY.
2853Restore which buffer appears in which window, where display starts,
2854and the value of point and mark for each window.
2855Also restore the choice of selected window.
2856Also restore which buffer is current.
2857Does not restore the value of point in current buffer.
2858
2859BEWARE: Most uses of this macro introduce bugs.
2860E.g. it should not be used to try and prevent some code from opening
2861a new window, since that window may sometimes appear in another frame,
2862in which case `save-window-excursion' cannot help."
2863 (declare (indent 0) (debug t))
2864 (let ((c (make-symbol "wconfig")))
2865 `(let ((,c (current-window-configuration)))
2866 (unwind-protect (progn ,@body)
2867 (set-window-configuration ,c)))))
2868
2869(defmacro with-output-to-temp-buffer (bufname &rest body)
2870 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
2871
2872This construct makes buffer BUFNAME empty before running BODY.
2873It does not make the buffer current for BODY.
2874Instead it binds `standard-output' to that buffer, so that output
2875generated with `prin1' and similar functions in BODY goes into
2876the buffer.
2877
2878At the end of BODY, this marks buffer BUFNAME unmodifed and displays
2879it in a window, but does not select it. The normal way to do this is
2880by calling `display-buffer', then running `temp-buffer-show-hook'.
2881However, if `temp-buffer-show-function' is non-nil, it calls that
2882function instead (and does not run `temp-buffer-show-hook'). The
2883function gets one argument, the buffer to display.
2884
2885The return value of `with-output-to-temp-buffer' is the value of the
2886last form in BODY. If BODY does not finish normally, the buffer
2887BUFNAME is not displayed.
2888
2889This runs the hook `temp-buffer-setup-hook' before BODY,
2890with the buffer BUFNAME temporarily current. It runs the hook
2891`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
2892buffer temporarily current, and the window that was used to display it
2893temporarily selected. But it doesn't run `temp-buffer-show-hook'
2894if it uses `temp-buffer-show-function'."
2895 (let ((old-dir (make-symbol "old-dir"))
2896 (buf (make-symbol "buf")))
2897 `(let* ((,old-dir default-directory)
2898 (,buf
2899 (with-current-buffer (get-buffer-create ,bufname)
2900 (prog1 (current-buffer)
2901 (kill-all-local-variables)
2902 ;; FIXME: delete_all_overlays
2903 (setq default-directory ,old-dir)
2904 (setq buffer-read-only nil)
2905 (setq buffer-file-name nil)
2906 (setq buffer-undo-list t)
2907 (let ((inhibit-read-only t)
2908 (inhibit-modification-hooks t))
2909 (erase-buffer)
2910 (run-hooks 'temp-buffer-setup-hook)))))
2911 (standard-output ,buf))
2912 (prog1 (progn ,@body)
2913 (internal-temp-output-buffer-show ,buf)))))
2914
2766(defmacro with-temp-file (file &rest body) 2915(defmacro with-temp-file (file &rest body)
2767 "Create a new buffer, evaluate BODY there, and write the buffer to FILE. 2916 "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
2768The value returned is the value of the last form in BODY. 2917The value returned is the value of the last form in BODY.
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el
index 831d4e86676..bc5326240a3 100644
--- a/lisp/textmodes/bibtex-style.el
+++ b/lisp/textmodes/bibtex-style.el
@@ -1,4 +1,4 @@
1;;; bibtex-style.el --- Major mode for BibTeX Style files 1;;; bibtex-style.el --- Major mode for BibTeX Style files -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
4 4
@@ -141,7 +141,7 @@
141 (looking-at "if\\$")) 141 (looking-at "if\\$"))
142 (scan-error nil)))) 142 (scan-error nil))))
143 (save-excursion 143 (save-excursion
144 (condition-case err 144 (condition-case nil
145 (while (progn 145 (while (progn
146 (backward-sexp 1) 146 (backward-sexp 1)
147 (save-excursion (skip-chars-backward " \t{") (not (bolp))))) 147 (save-excursion (skip-chars-backward " \t{") (not (bolp)))))
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index b611261723a..ef51fb25035 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -1,4 +1,4 @@
1;;; css-mode.el --- Major mode to edit CSS files 1;;; css-mode.el --- Major mode to edit CSS files -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2006-2011 Free Software Foundation, Inc. 3;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
4 4
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index e894127cdb1..3153e143ba3 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -1,4 +1,4 @@
1;;; uniquify.el --- unique buffer names dependent on file name 1;;; uniquify.el --- unique buffer names dependent on file name -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc.
4 4
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el
index 7354e616c99..063eb414579 100644
--- a/lisp/vc/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -1,4 +1,4 @@
1;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*- 1;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8; lexical-binding: t -*-
2 2
3;; Copyright (C) 1999-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
4 4
@@ -87,6 +87,12 @@
87 '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) 87 '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
88 88
89(defvar cvs-minor-wrap-function) 89(defvar cvs-minor-wrap-function)
90(defvar cvs-force-command)
91(defvar cvs-minor-current-files)
92(defvar cvs-secondary-branch-prefix)
93(defvar cvs-branch-prefix)
94(defvar cvs-tag-print-rev)
95
90(put 'cvs-status-mode 'mode-class 'special) 96(put 'cvs-status-mode 'mode-class 'special)
91;;;###autoload 97;;;###autoload
92(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" 98(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
@@ -472,7 +478,7 @@ Optional prefix ARG chooses between two representations."
472 (nprev (if (and cvs-tree-nomerge next 478 (nprev (if (and cvs-tree-nomerge next
473 (equal vlist (cvs-tag->vlist next))) 479 (equal vlist (cvs-tag->vlist next)))
474 prev vlist))) 480 prev vlist)))
475 (cvs-map (lambda (v p) v) nprev prev))) 481 (cvs-map (lambda (v _p) v) nprev prev)))
476 (after (save-excursion 482 (after (save-excursion
477 (newline) 483 (newline)
478 (cvs-tree-tags-insert (cdr tags) nprev))) 484 (cvs-tree-tags-insert (cdr tags) nprev)))
@@ -512,24 +518,24 @@ Optional prefix ARG chooses between two representations."
512;;;; Merged trees from different files 518;;;; Merged trees from different files
513;;;; 519;;;;
514 520
515(defun cvs-tree-fuzzy-merge-1 (trees tree prev) 521;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
516 ) 522;; )
517 523
518(defun cvs-tree-fuzzy-merge (trees tree) 524;; (defun cvs-tree-fuzzy-merge (trees tree)
519 "Do the impossible: merge TREE into TREES." 525;; "Do the impossible: merge TREE into TREES."
520 ()) 526;; ())
521 527
522(defun cvs-tree () 528;; (defun cvs-tree ()
523 "Get tags from the status output and merge tham all into a big tree." 529;; "Get tags from the status output and merge them all into a big tree."
524 (save-excursion 530;; (save-excursion
525 (goto-char (point-min)) 531;; (goto-char (point-min))
526 (let ((inhibit-read-only t) 532;; (let ((inhibit-read-only t)
527 (trees (make-vector 31 0)) tree) 533;; (trees (make-vector 31 0)) tree)
528 (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) 534;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
529 (cvs-tree-fuzzy-merge trees tree)) 535;; (cvs-tree-fuzzy-merge trees tree))
530 (erase-buffer) 536;; (erase-buffer)
531 (let ((cvs-tag-print-rev nil)) 537;; (let ((cvs-tag-print-rev nil))
532 (cvs-tree-print tree 'cvs-tag->string 3))))) 538;; (cvs-tree-print tree 'cvs-tag->string 3)))))
533 539
534 540
535(provide 'cvs-status) 541(provide 'cvs-status)
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 72f415a9b94..50f20cea779 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -1,4 +1,4 @@
1;;; diff-mode.el --- a mode for viewing/editing context diffs 1;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1998-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
4 4
@@ -814,7 +814,7 @@ PREFIX is only used internally: don't use it."
814(defun diff-ediff-patch () 814(defun diff-ediff-patch ()
815 "Call `ediff-patch-file' on the current buffer." 815 "Call `ediff-patch-file' on the current buffer."
816 (interactive) 816 (interactive)
817 (condition-case err 817 (condition-case nil
818 (ediff-patch-file nil (current-buffer)) 818 (ediff-patch-file nil (current-buffer))
819 (wrong-number-of-arguments (ediff-patch-file)))) 819 (wrong-number-of-arguments (ediff-patch-file))))
820 820
@@ -1171,7 +1171,7 @@ else cover the whole buffer."
1171;; *-change-function is asking for trouble, whereas making them 1171;; *-change-function is asking for trouble, whereas making them
1172;; from a post-command-hook doesn't pose much problems 1172;; from a post-command-hook doesn't pose much problems
1173(defvar diff-unhandled-changes nil) 1173(defvar diff-unhandled-changes nil)
1174(defun diff-after-change-function (beg end len) 1174(defun diff-after-change-function (beg end _len)
1175 "Remember to fixup the hunk header. 1175 "Remember to fixup the hunk header.
1176See `after-change-functions' for the meaning of BEG, END and LEN." 1176See `after-change-functions' for the meaning of BEG, END and LEN."
1177 ;; Ignoring changes when inhibit-read-only is set is strictly speaking 1177 ;; Ignoring changes when inhibit-read-only is set is strictly speaking
@@ -1281,7 +1281,7 @@ a diff with \\[diff-reverse-direction].
1281 (add-hook 'after-change-functions 'diff-after-change-function nil t) 1281 (add-hook 'after-change-functions 'diff-after-change-function nil t)
1282 (add-hook 'post-command-hook 'diff-post-command-hook nil t)) 1282 (add-hook 'post-command-hook 'diff-post-command-hook nil t))
1283 ;; Neat trick from Dave Love to add more bindings in read-only mode: 1283 ;; Neat trick from Dave Love to add more bindings in read-only mode:
1284 (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) 1284 (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
1285 (add-to-list 'minor-mode-overriding-map-alist ro-bind) 1285 (add-to-list 'minor-mode-overriding-map-alist ro-bind)
1286 ;; Turn off this little trick in case the buffer is put in view-mode. 1286 ;; Turn off this little trick in case the buffer is put in view-mode.
1287 (add-hook 'view-mode-hook 1287 (add-hook 'view-mode-hook
@@ -1693,7 +1693,7 @@ With a prefix argument, REVERSE the hunk."
1693 "See whether it's possible to apply the current hunk. 1693 "See whether it's possible to apply the current hunk.
1694With a prefix argument, try to REVERSE the hunk." 1694With a prefix argument, try to REVERSE the hunk."
1695 (interactive "P") 1695 (interactive "P")
1696 (destructuring-bind (buf line-offset pos src dst &optional switched) 1696 (destructuring-bind (buf line-offset pos src _dst &optional switched)
1697 (diff-find-source-location nil reverse) 1697 (diff-find-source-location nil reverse)
1698 (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) 1698 (set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
1699 (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) 1699 (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
@@ -1713,7 +1713,7 @@ then `diff-jump-to-old-file' is also set, for the next invocations."
1713 ;; This is a convenient detail when using smerge-diff. 1713 ;; This is a convenient detail when using smerge-diff.
1714 (if event (posn-set-point (event-end event))) 1714 (if event (posn-set-point (event-end event)))
1715 (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) 1715 (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
1716 (destructuring-bind (buf line-offset pos src dst &optional switched) 1716 (destructuring-bind (buf line-offset pos src _dst &optional switched)
1717 (diff-find-source-location other-file rev) 1717 (diff-find-source-location other-file rev)
1718 (pop-to-buffer buf) 1718 (pop-to-buffer buf)
1719 (goto-char (+ (car pos) (cdr src))) 1719 (goto-char (+ (car pos) (cdr src)))
@@ -1731,7 +1731,7 @@ For use in `add-log-current-defun-function'."
1731 (when (looking-at diff-hunk-header-re) 1731 (when (looking-at diff-hunk-header-re)
1732 (forward-line 1) 1732 (forward-line 1)
1733 (re-search-forward "^[^ ]" nil t)) 1733 (re-search-forward "^[^ ]" nil t))
1734 (destructuring-bind (&optional buf line-offset pos src dst switched) 1734 (destructuring-bind (&optional buf _line-offset pos src dst switched)
1735 ;; Use `noprompt' since this is used in which-func-mode and such. 1735 ;; Use `noprompt' since this is used in which-func-mode and such.
1736 (ignore-errors ;Signals errors in place of prompting. 1736 (ignore-errors ;Signals errors in place of prompting.
1737 (diff-find-source-location nil nil 'noprompt)) 1737 (diff-find-source-location nil nil 'noprompt))
@@ -1879,28 +1879,27 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks."
1879 ;; good to call it for each change. 1879 ;; good to call it for each change.
1880 (save-excursion 1880 (save-excursion
1881 (goto-char (point-min)) 1881 (goto-char (point-min))
1882 (let ((orig-buffer (current-buffer))) 1882 (condition-case nil
1883 (condition-case nil 1883 ;; Call add-change-log-entry-other-window for each hunk in
1884 ;; Call add-change-log-entry-other-window for each hunk in 1884 ;; the diff buffer.
1885 ;; the diff buffer. 1885 (while (progn
1886 (while (progn 1886 (diff-hunk-next)
1887 (diff-hunk-next) 1887 ;; Move to where the changes are,
1888 ;; Move to where the changes are, 1888 ;; `add-change-log-entry-other-window' works better in
1889 ;; `add-change-log-entry-other-window' works better in 1889 ;; that case.
1890 ;; that case. 1890 (re-search-forward
1891 (re-search-forward 1891 (concat "\n[!+-<>]"
1892 (concat "\n[!+-<>]" 1892 ;; If the hunk is a context hunk with an empty first
1893 ;; If the hunk is a context hunk with an empty first 1893 ;; half, recognize the "--- NNN,MMM ----" line
1894 ;; half, recognize the "--- NNN,MMM ----" line 1894 "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
1895 "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n" 1895 ;; and skip to the next non-context line.
1896 ;; and skip to the next non-context line. 1896 "\\( .*\n\\)*[+]\\)?")
1897 "\\( .*\n\\)*[+]\\)?") 1897 nil t))
1898 nil t)) 1898 (save-excursion
1899 (save-excursion 1899 ;; FIXME: this pops up windows of all the buffers.
1900 ;; FIXME: this pops up windows of all the buffers. 1900 (add-change-log-entry nil nil t nil t)))
1901 (add-change-log-entry nil nil t nil t))) 1901 ;; When there's no more hunks, diff-hunk-next signals an error.
1902 ;; When there's no more hunks, diff-hunk-next signals an error. 1902 (error nil))))
1903 (error nil)))))
1904 1903
1905;; provide the package 1904;; provide the package
1906(provide 'diff-mode) 1905(provide 'diff-mode)
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index 192ab1f78d2..54a2cb4f196 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -1,4 +1,4 @@
1;;; log-edit.el --- Major mode for editing CVS commit messages 1;;; log-edit.el --- Major mode for editing CVS commit messages -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1999-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
4 4
@@ -329,7 +329,7 @@ automatically."
329(defconst log-edit-header-contents-regexp 329(defconst log-edit-header-contents-regexp
330 "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?") 330 "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
331 331
332(defun log-edit-match-to-eoh (limit) 332(defun log-edit-match-to-eoh (_limit)
333 ;; FIXME: copied from message-match-to-eoh. 333 ;; FIXME: copied from message-match-to-eoh.
334 (let ((start (point))) 334 (let ((start (point)))
335 (rfc822-goto-eoh) 335 (rfc822-goto-eoh)
@@ -361,7 +361,7 @@ automatically."
361 nil lax))))) 361 nil lax)))))
362 362
363;;;###autoload 363;;;###autoload
364(defun log-edit (callback &optional setup params buffer mode &rest ignore) 364(defun log-edit (callback &optional setup params buffer mode &rest _ignore)
365 "Setup a buffer to enter a log message. 365 "Setup a buffer to enter a log message.
366\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode' 366\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
367if MODE is nil. 367if MODE is nil.
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el
index cb1c181fa61..9f6ad19fdb1 100644
--- a/lisp/vc/log-view.el
+++ b/lisp/vc/log-view.el
@@ -1,4 +1,4 @@
1;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output 1;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1999-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
4 4
@@ -115,6 +115,7 @@
115(autoload 'vc-diff-internal "vc") 115(autoload 'vc-diff-internal "vc")
116 116
117(defvar cvs-minor-wrap-function) 117(defvar cvs-minor-wrap-function)
118(defvar cvs-force-command)
118 119
119(defgroup log-view nil 120(defgroup log-view nil
120 "Major mode for browsing log output of RCS/CVS/SCCS." 121 "Major mode for browsing log output of RCS/CVS/SCCS."
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index 37cdd41ee55..75e3b514531 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -1,4 +1,4 @@
1;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts 1;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1999-2011 Free Software Foundation, Inc. 3;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
4 4
diff --git a/src/ChangeLog b/src/ChangeLog
index 99447fd8748..56400fbb08f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -35,6 +35,64 @@
35 * deps.mk (sysdep.o): Depend on ../lib/allocator.h and on 35 * deps.mk (sysdep.o): Depend on ../lib/allocator.h and on
36 ../lib/careadlinkat.h. 36 ../lib/careadlinkat.h.
37 37
382011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
39
40 Add lexical binding.
41
42 * window.c (Ftemp_output_buffer_show): New fun.
43 (Fsave_window_excursion):
44 * print.c (Fwith_output_to_temp_buffer): Move to subr.el.
45
46 * lread.c (lisp_file_lexically_bound_p): New function.
47 (Fload): Bind Qlexical_binding.
48 (readevalloop): Remove `evalfun' arg.
49 Bind Qinternal_interpreter_environment.
50 (Feval_buffer): Bind Qlexical_binding.
51 (defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard):
52 Mark as dynamic.
53 (syms_of_lread): Declare `lexical-binding'.
54
55 * lisp.h (struct Lisp_Symbol): New field `declared_special'.
56
57 * keyboard.c (eval_dyn): New fun.
58 (menu_item_eval_property): Use it.
59
60 * image.c (parse_image_spec): Use Ffunctionp.
61
62 * fns.c (concat, mapcar1): Accept byte-code-functions.
63
64 * eval.c (Fsetq): Handle lexical vars.
65 (Fdefun, Fdefmacro, Ffunction): Make closures when needed.
66 (Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic.
67 (FletX, Flet): Obey lexical binding.
68 (Fcommandp): Handle closures.
69 (Feval): New `lexical' arg.
70 (eval_sub): New function extracted from Feval. Use it almost
71 everywhere where Feval was used. Look up vars in lexical env.
72 Handle closures.
73 (Ffunctionp): Move from subr.el.
74 (Ffuncall): Handle closures.
75 (apply_lambda): Remove `eval_flags'.
76 (funcall_lambda): Handle closures and new byte-code-functions.
77 (Fspecial_variable_p): New function.
78 (syms_of_eval): Initialize the Vinternal_interpreter_environment var,
79 but without exporting it to Lisp.
80
81 * doc.c (Fdocumentation, store_function_docstring):
82 * data.c (Finteractive_form): Handle closures.
83
84 * callint.c (Fcall_interactively): Preserve lexical-binding mode for
85 interactive spec.
86
87 * bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN): New
88 byte-codes.
89 (exec_byte_code): New function extracted from Fbyte_code to handle new
90 calling convention for byte-code-functions. Add new byte-codes.
91
92 * buffer.c (defvar_per_buffer): Set new `declared_special' field.
93
94 * alloc.c (Fmake_symbol): Init new `declared_special' field.
95
382011-03-31 Juanma Barranquero <lekktu@gmail.com> 962011-03-31 Juanma Barranquero <lekktu@gmail.com>
39 97
40 * xdisp.c (redisplay_internal): Fix prototype. 98 * xdisp.c (redisplay_internal): Fix prototype.
diff --git a/src/alloc.c b/src/alloc.c
index 177a2266fb6..07f1caae46b 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -2940,10 +2940,19 @@ usage: (vector &rest OBJECTS) */)
2940 2940
2941DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 2941DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
2942 doc: /* Create a byte-code object with specified arguments as elements. 2942 doc: /* Create a byte-code object with specified arguments as elements.
2943The arguments should be the arglist, bytecode-string, constant vector, 2943The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
2944stack size, (optional) doc string, and (optional) interactive spec. 2944vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
2945and (optional) INTERACTIVE-SPEC.
2945The first four arguments are required; at most six have any 2946The first four arguments are required; at most six have any
2946significance. 2947significance.
2948The ARGLIST can be either like the one of `lambda', in which case the arguments
2949will be dynamically bound before executing the byte code, or it can be an
2950integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
2951minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
2952of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
2953argument to catch the left-over arguments. If such an integer is used, the
2954arguments will not be dynamically bound but will be instead pushed on the
2955stack before executing the byte-code.
2947usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) 2956usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2948 (register size_t nargs, Lisp_Object *args) 2957 (register size_t nargs, Lisp_Object *args)
2949{ 2958{
@@ -3071,6 +3080,7 @@ Its value and function definition are void, and its property list is nil. */)
3071 p->gcmarkbit = 0; 3080 p->gcmarkbit = 0;
3072 p->interned = SYMBOL_UNINTERNED; 3081 p->interned = SYMBOL_UNINTERNED;
3073 p->constant = 0; 3082 p->constant = 0;
3083 p->declared_special = 0;
3074 consing_since_gc += sizeof (struct Lisp_Symbol); 3084 consing_since_gc += sizeof (struct Lisp_Symbol);
3075 symbols_consed++; 3085 symbols_consed++;
3076 return val; 3086 return val;
diff --git a/src/buffer.c b/src/buffer.c
index 8b56b285e48..cdcd2ccecff 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -5240,6 +5240,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring,
5240 bo_fwd->type = Lisp_Fwd_Buffer_Obj; 5240 bo_fwd->type = Lisp_Fwd_Buffer_Obj;
5241 bo_fwd->offset = offset; 5241 bo_fwd->offset = offset;
5242 bo_fwd->slottype = type; 5242 bo_fwd->slottype = type;
5243 sym->declared_special = 1;
5243 sym->redirect = SYMBOL_FORWARDED; 5244 sym->redirect = SYMBOL_FORWARDED;
5244 { 5245 {
5245 /* I tried to do the job without a cast, but it seems impossible. 5246 /* I tried to do the job without a cast, but it seems impossible.
diff --git a/src/bytecode.c b/src/bytecode.c
index 5a62c913a40..5879d312b07 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -80,9 +80,11 @@ Lisp_Object Qbyte_code_meter;
80 80
81 81
82Lisp_Object Qbytecode; 82Lisp_Object Qbytecode;
83extern Lisp_Object Qand_optional, Qand_rest;
83 84
84/* Byte codes: */ 85/* Byte codes: */
85 86
87#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */
86#define Bvarref 010 88#define Bvarref 010
87#define Bvarset 020 89#define Bvarset 020
88#define Bvarbind 030 90#define Bvarbind 030
@@ -132,7 +134,7 @@ Lisp_Object Qbytecode;
132 134
133#define Bpoint 0140 135#define Bpoint 0140
134/* Was Bmark in v17. */ 136/* Was Bmark in v17. */
135#define Bsave_current_buffer 0141 137#define Bsave_current_buffer 0141 /* Obsolete. */
136#define Bgoto_char 0142 138#define Bgoto_char 0142
137#define Binsert 0143 139#define Binsert 0143
138#define Bpoint_max 0144 140#define Bpoint_max 0144
@@ -158,7 +160,7 @@ Lisp_Object Qbytecode;
158#ifdef BYTE_CODE_SAFE 160#ifdef BYTE_CODE_SAFE
159#define Bset_mark 0163 /* this loser is no longer generated as of v18 */ 161#define Bset_mark 0163 /* this loser is no longer generated as of v18 */
160#endif 162#endif
161#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ 163#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */
162 164
163#define Bforward_char 0165 165#define Bforward_char 0165
164#define Bforward_word 0166 166#define Bforward_word 0166
@@ -183,16 +185,16 @@ Lisp_Object Qbytecode;
183#define Bdup 0211 185#define Bdup 0211
184 186
185#define Bsave_excursion 0212 187#define Bsave_excursion 0212
186#define Bsave_window_excursion 0213 188#define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1. */
187#define Bsave_restriction 0214 189#define Bsave_restriction 0214
188#define Bcatch 0215 190#define Bcatch 0215
189 191
190#define Bunwind_protect 0216 192#define Bunwind_protect 0216
191#define Bcondition_case 0217 193#define Bcondition_case 0217
192#define Btemp_output_buffer_setup 0220 194#define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1. */
193#define Btemp_output_buffer_show 0221 195#define Btemp_output_buffer_show 0221 /* Obsolete since Emacs-24.1. */
194 196
195#define Bunbind_all 0222 197#define Bunbind_all 0222 /* Obsolete. Never used. */
196 198
197#define Bset_marker 0223 199#define Bset_marker 0223
198#define Bmatch_beginning 0224 200#define Bmatch_beginning 0224
@@ -228,6 +230,11 @@ Lisp_Object Qbytecode;
228#define BconcatN 0260 230#define BconcatN 0260
229#define BinsertN 0261 231#define BinsertN 0261
230 232
233/* Bstack_ref is code 0. */
234#define Bstack_set 0262
235#define Bstack_set2 0263
236#define BdiscardN 0266
237
231#define Bconstant 0300 238#define Bconstant 0300
232 239
233/* Whether to maintain a `top' and `bottom' field in the stack frame. */ 240/* Whether to maintain a `top' and `bottom' field in the stack frame. */
@@ -414,6 +421,21 @@ the third, MAXDEPTH, the maximum stack depth used in this function.
414If the third argument is incorrect, Emacs may crash. */) 421If the third argument is incorrect, Emacs may crash. */)
415 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) 422 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
416{ 423{
424 return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
425}
426
427/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
428 MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
429 emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
430 argument list (including &rest, &optional, etc.), and ARGS, of size
431 NARGS, should be a vector of the actual arguments. The arguments in
432 ARGS are pushed on the stack according to ARGS_TEMPLATE before
433 executing BYTESTR. */
434
435Lisp_Object
436exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
437 Lisp_Object args_template, int nargs, Lisp_Object *args)
438{
417 int count = SPECPDL_INDEX (); 439 int count = SPECPDL_INDEX ();
418#ifdef BYTE_CODE_METER 440#ifdef BYTE_CODE_METER
419 int this_op = 0; 441 int this_op = 0;
@@ -475,6 +497,52 @@ If the third argument is incorrect, Emacs may crash. */)
475 stacke = stack.bottom - 1 + XFASTINT (maxdepth); 497 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
476#endif 498#endif
477 499
500 if (INTEGERP (args_template))
501 {
502 int at = XINT (args_template);
503 int rest = at & 128;
504 int mandatory = at & 127;
505 int nonrest = at >> 8;
506 eassert (mandatory <= nonrest);
507 if (nargs <= nonrest)
508 {
509 int i;
510 for (i = 0 ; i < nargs; i++, args++)
511 PUSH (*args);
512 if (nargs < mandatory)
513 /* Too few arguments. */
514 Fsignal (Qwrong_number_of_arguments,
515 Fcons (Fcons (make_number (mandatory),
516 rest ? Qand_rest : make_number (nonrest)),
517 Fcons (make_number (nargs), Qnil)));
518 else
519 {
520 for (; i < nonrest; i++)
521 PUSH (Qnil);
522 if (rest)
523 PUSH (Qnil);
524 }
525 }
526 else if (rest)
527 {
528 int i;
529 for (i = 0 ; i < nonrest; i++, args++)
530 PUSH (*args);
531 PUSH (Flist (nargs - nonrest, args));
532 }
533 else
534 /* Too many arguments. */
535 Fsignal (Qwrong_number_of_arguments,
536 Fcons (Fcons (make_number (mandatory),
537 make_number (nonrest)),
538 Fcons (make_number (nargs), Qnil)));
539 }
540 else if (! NILP (args_template))
541 /* We should push some arguments on the stack. */
542 {
543 error ("Unknown args template!");
544 }
545
478 while (1) 546 while (1)
479 { 547 {
480#ifdef BYTE_CODE_SAFE 548#ifdef BYTE_CODE_SAFE
@@ -735,7 +803,7 @@ If the third argument is incorrect, Emacs may crash. */)
735 AFTER_POTENTIAL_GC (); 803 AFTER_POTENTIAL_GC ();
736 break; 804 break;
737 805
738 case Bunbind_all: 806 case Bunbind_all: /* Obsolete. Never used. */
739 /* To unbind back to the beginning of this frame. Not used yet, 807 /* To unbind back to the beginning of this frame. Not used yet,
740 but will be needed for tail-recursion elimination. */ 808 but will be needed for tail-recursion elimination. */
741 BEFORE_POTENTIAL_GC (); 809 BEFORE_POTENTIAL_GC ();
@@ -863,37 +931,43 @@ If the third argument is incorrect, Emacs may crash. */)
863 save_excursion_save ()); 931 save_excursion_save ());
864 break; 932 break;
865 933
866 case Bsave_current_buffer: 934 case Bsave_current_buffer: /* Obsolete since ??. */
867 case Bsave_current_buffer_1: 935 case Bsave_current_buffer_1:
868 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); 936 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
869 break; 937 break;
870 938
871 case Bsave_window_excursion: 939 case Bsave_window_excursion: /* Obsolete since 24.1. */
872 BEFORE_POTENTIAL_GC (); 940 {
873 TOP = Fsave_window_excursion (TOP); 941 register int count = SPECPDL_INDEX ();
874 AFTER_POTENTIAL_GC (); 942 record_unwind_protect (Fset_window_configuration,
875 break; 943 Fcurrent_window_configuration (Qnil));
944 BEFORE_POTENTIAL_GC ();
945 TOP = Fprogn (TOP);
946 unbind_to (count, TOP);
947 AFTER_POTENTIAL_GC ();
948 break;
949 }
876 950
877 case Bsave_restriction: 951 case Bsave_restriction:
878 record_unwind_protect (save_restriction_restore, 952 record_unwind_protect (save_restriction_restore,
879 save_restriction_save ()); 953 save_restriction_save ());
880 break; 954 break;
881 955
882 case Bcatch: 956 case Bcatch: /* FIXME: ill-suited for lexbind */
883 { 957 {
884 Lisp_Object v1; 958 Lisp_Object v1;
885 BEFORE_POTENTIAL_GC (); 959 BEFORE_POTENTIAL_GC ();
886 v1 = POP; 960 v1 = POP;
887 TOP = internal_catch (TOP, Feval, v1); 961 TOP = internal_catch (TOP, eval_sub, v1);
888 AFTER_POTENTIAL_GC (); 962 AFTER_POTENTIAL_GC ();
889 break; 963 break;
890 } 964 }
891 965
892 case Bunwind_protect: 966 case Bunwind_protect: /* FIXME: avoid closure for lexbind */
893 record_unwind_protect (Fprogn, POP); 967 record_unwind_protect (Fprogn, POP);
894 break; 968 break;
895 969
896 case Bcondition_case: 970 case Bcondition_case: /* FIXME: ill-suited for lexbind */
897 { 971 {
898 Lisp_Object handlers, body; 972 Lisp_Object handlers, body;
899 handlers = POP; 973 handlers = POP;
@@ -904,7 +978,7 @@ If the third argument is incorrect, Emacs may crash. */)
904 break; 978 break;
905 } 979 }
906 980
907 case Btemp_output_buffer_setup: 981 case Btemp_output_buffer_setup: /* Obsolete since 24.1. */
908 BEFORE_POTENTIAL_GC (); 982 BEFORE_POTENTIAL_GC ();
909 CHECK_STRING (TOP); 983 CHECK_STRING (TOP);
910 temp_output_buffer_setup (SSDATA (TOP)); 984 temp_output_buffer_setup (SSDATA (TOP));
@@ -912,7 +986,7 @@ If the third argument is incorrect, Emacs may crash. */)
912 TOP = Vstandard_output; 986 TOP = Vstandard_output;
913 break; 987 break;
914 988
915 case Btemp_output_buffer_show: 989 case Btemp_output_buffer_show: /* Obsolete since 24.1. */
916 { 990 {
917 Lisp_Object v1; 991 Lisp_Object v1;
918 BEFORE_POTENTIAL_GC (); 992 BEFORE_POTENTIAL_GC ();
@@ -1384,7 +1458,7 @@ If the third argument is incorrect, Emacs may crash. */)
1384 AFTER_POTENTIAL_GC (); 1458 AFTER_POTENTIAL_GC ();
1385 break; 1459 break;
1386 1460
1387 case Binteractive_p: 1461 case Binteractive_p: /* Obsolete since 24.1. */
1388 PUSH (Finteractive_p ()); 1462 PUSH (Finteractive_p ());
1389 break; 1463 break;
1390 1464
@@ -1674,8 +1748,57 @@ If the third argument is incorrect, Emacs may crash. */)
1674#endif 1748#endif
1675 1749
1676 case 0: 1750 case 0:
1751 /* Actually this is Bstack_ref with offset 0, but we use Bdup
1752 for that instead. */
1753 /* case Bstack_ref: */
1677 abort (); 1754 abort ();
1678 1755
1756 /* Handy byte-codes for lexical binding. */
1757 case Bstack_ref+1:
1758 case Bstack_ref+2:
1759 case Bstack_ref+3:
1760 case Bstack_ref+4:
1761 case Bstack_ref+5:
1762 {
1763 Lisp_Object *ptr = top - (op - Bstack_ref);
1764 PUSH (*ptr);
1765 break;
1766 }
1767 case Bstack_ref+6:
1768 {
1769 Lisp_Object *ptr = top - (FETCH);
1770 PUSH (*ptr);
1771 break;
1772 }
1773 case Bstack_ref+7:
1774 {
1775 Lisp_Object *ptr = top - (FETCH2);
1776 PUSH (*ptr);
1777 break;
1778 }
1779 /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
1780 case Bstack_set:
1781 {
1782 Lisp_Object *ptr = top - (FETCH);
1783 *ptr = POP;
1784 break;
1785 }
1786 case Bstack_set2:
1787 {
1788 Lisp_Object *ptr = top - (FETCH2);
1789 *ptr = POP;
1790 break;
1791 }
1792 case BdiscardN:
1793 op = FETCH;
1794 if (op & 0x80)
1795 {
1796 op &= 0x7F;
1797 top[-op] = TOP;
1798 }
1799 DISCARD (op);
1800 break;
1801
1679 case 255: 1802 case 255:
1680 default: 1803 default:
1681#ifdef BYTE_CODE_SAFE 1804#ifdef BYTE_CODE_SAFE
diff --git a/src/callint.c b/src/callint.c
index 40d89acd16c..60570369d9e 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -121,8 +121,9 @@ usage: (interactive &optional ARGS) */)
121static Lisp_Object 121static Lisp_Object
122quotify_arg (register Lisp_Object exp) 122quotify_arg (register Lisp_Object exp)
123{ 123{
124 if (!INTEGERP (exp) && !STRINGP (exp) 124 if (CONSP (exp)
125 && !NILP (exp) && !EQ (exp, Qt)) 125 || (SYMBOLP (exp)
126 && !NILP (exp) && !EQ (exp, Qt)))
126 return Fcons (Qquote, Fcons (exp, Qnil)); 127 return Fcons (Qquote, Fcons (exp, Qnil));
127 128
128 return exp; 129 return exp;
@@ -169,6 +170,9 @@ check_mark (int for_region)
169static void 170static void
170fix_command (Lisp_Object input, Lisp_Object values) 171fix_command (Lisp_Object input, Lisp_Object values)
171{ 172{
173 /* FIXME: Instead of this ugly hack, we should provide a way for an
174 interactive spec to return an expression/function that will re-build the
175 args without user intervention. */
172 if (CONSP (input)) 176 if (CONSP (input))
173 { 177 {
174 Lisp_Object car; 178 Lisp_Object car;
@@ -332,11 +336,14 @@ invoke it. If KEYS is omitted or nil, the return value of
332 else 336 else
333 { 337 {
334 Lisp_Object input; 338 Lisp_Object input;
339 Lisp_Object funval = Findirect_function (function, Qt);
335 i = num_input_events; 340 i = num_input_events;
336 input = specs; 341 input = specs;
337 /* Compute the arg values using the user's expression. */ 342 /* Compute the arg values using the user's expression. */
338 GCPRO2 (input, filter_specs); 343 GCPRO2 (input, filter_specs);
339 specs = Feval (specs); 344 specs = Feval (specs,
345 CONSP (funval) && EQ (Qclosure, XCAR (funval))
346 ? Qt : Qnil);
340 UNGCPRO; 347 UNGCPRO;
341 if (i != num_input_events || !NILP (record_flag)) 348 if (i != num_input_events || !NILP (record_flag))
342 { 349 {
diff --git a/src/data.c b/src/data.c
index ba7ae58d7b2..4b9d2ec0387 100644
--- a/src/data.c
+++ b/src/data.c
@@ -745,7 +745,9 @@ Value, if non-nil, is a list \(interactive SPEC). */)
745 else if (CONSP (fun)) 745 else if (CONSP (fun))
746 { 746 {
747 Lisp_Object funcar = XCAR (fun); 747 Lisp_Object funcar = XCAR (fun);
748 if (EQ (funcar, Qlambda)) 748 if (EQ (funcar, Qclosure))
749 return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
750 else if (EQ (funcar, Qlambda))
749 return Fassq (Qinteractive, Fcdr (XCDR (fun))); 751 return Fassq (Qinteractive, Fcdr (XCDR (fun)));
750 else if (EQ (funcar, Qautoload)) 752 else if (EQ (funcar, Qautoload))
751 { 753 {
@@ -1431,7 +1433,7 @@ usage: (setq-default [VAR VALUE]...) */)
1431 1433
1432 do 1434 do
1433 { 1435 {
1434 val = Feval (Fcar (Fcdr (args_left))); 1436 val = eval_sub (Fcar (Fcdr (args_left)));
1435 symbol = XCAR (args_left); 1437 symbol = XCAR (args_left);
1436 Fset_default (symbol, val); 1438 Fset_default (symbol, val);
1437 args_left = Fcdr (XCDR (args_left)); 1439 args_left = Fcdr (XCDR (args_left));
@@ -2101,7 +2103,7 @@ or a byte-code object. IDX starts at 0. */)
2101 2103
2102 if (idxval < 0 || idxval >= size) 2104 if (idxval < 0 || idxval >= size)
2103 args_out_of_range (array, idx); 2105 args_out_of_range (array, idx);
2104 return XVECTOR (array)->contents[idxval]; 2106 return AREF (array, idxval);
2105 } 2107 }
2106} 2108}
2107 2109
diff --git a/src/doc.c b/src/doc.c
index 1ed9949e52c..158b09790f7 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
36 36
37Lisp_Object Qfunction_documentation; 37Lisp_Object Qfunction_documentation;
38 38
39extern Lisp_Object Qclosure;
39/* Buffer used for reading from documentation file. */ 40/* Buffer used for reading from documentation file. */
40static char *get_doc_string_buffer; 41static char *get_doc_string_buffer;
41static int get_doc_string_buffer_size; 42static int get_doc_string_buffer_size;
@@ -374,6 +375,7 @@ string is passed through `substitute-command-keys'. */)
374 else if (EQ (funcar, Qkeymap)) 375 else if (EQ (funcar, Qkeymap))
375 return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); 376 return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
376 else if (EQ (funcar, Qlambda) 377 else if (EQ (funcar, Qlambda)
378 || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
377 || EQ (funcar, Qautoload)) 379 || EQ (funcar, Qautoload))
378 { 380 {
379 Lisp_Object tem1 = Fcdr (Fcdr (fun)); 381 Lisp_Object tem1 = Fcdr (Fcdr (fun));
@@ -480,7 +482,7 @@ aren't strings. */)
480 } 482 }
481 else if (!STRINGP (tem)) 483 else if (!STRINGP (tem))
482 /* Feval protects its argument. */ 484 /* Feval protects its argument. */
483 tem = Feval (tem); 485 tem = Feval (tem, Qnil);
484 486
485 if (NILP (raw) && STRINGP (tem)) 487 if (NILP (raw) && STRINGP (tem))
486 tem = Fsubstitute_command_keys (tem); 488 tem = Fsubstitute_command_keys (tem);
@@ -507,7 +509,8 @@ store_function_docstring (Lisp_Object fun, EMACS_INT offset)
507 Lisp_Object tem; 509 Lisp_Object tem;
508 510
509 tem = XCAR (fun); 511 tem = XCAR (fun);
510 if (EQ (tem, Qlambda) || EQ (tem, Qautoload)) 512 if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
513 || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
511 { 514 {
512 tem = Fcdr (Fcdr (fun)); 515 tem = Fcdr (Fcdr (fun));
513 if (CONSP (tem) && INTEGERP (XCAR (tem))) 516 if (CONSP (tem) && INTEGERP (XCAR (tem)))
diff --git a/src/eval.c b/src/eval.c
index 718e58c693f..948c2e4d158 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -64,6 +64,8 @@ Lisp_Object Qinhibit_quit;
64Lisp_Object Qand_rest, Qand_optional; 64Lisp_Object Qand_rest, Qand_optional;
65Lisp_Object Qdebug_on_error; 65Lisp_Object Qdebug_on_error;
66Lisp_Object Qdeclare; 66Lisp_Object Qdeclare;
67Lisp_Object Qinternal_interpreter_environment, Qclosure;
68
67Lisp_Object Qdebug; 69Lisp_Object Qdebug;
68 70
69/* This holds either the symbol `run-hooks' or nil. 71/* This holds either the symbol `run-hooks' or nil.
@@ -115,10 +117,10 @@ Lisp_Object Vsignaling_function;
115 117
116int handling_signal; 118int handling_signal;
117 119
118static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object*); 120static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object *);
119static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; 121static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;
120static int interactive_p (int); 122static int interactive_p (int);
121static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int); 123static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
122 124
123void 125void
124init_eval_once (void) 126init_eval_once (void)
@@ -127,7 +129,7 @@ init_eval_once (void)
127 specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); 129 specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
128 specpdl_ptr = specpdl; 130 specpdl_ptr = specpdl;
129 /* Don't forget to update docs (lispref node "Local Variables"). */ 131 /* Don't forget to update docs (lispref node "Local Variables"). */
130 max_specpdl_size = 1000; 132 max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
131 max_lisp_eval_depth = 600; 133 max_lisp_eval_depth = 600;
132 134
133 Vrun_hooks = Qnil; 135 Vrun_hooks = Qnil;
@@ -244,7 +246,7 @@ usage: (or CONDITIONS...) */)
244 246
245 while (CONSP (args)) 247 while (CONSP (args))
246 { 248 {
247 val = Feval (XCAR (args)); 249 val = eval_sub (XCAR (args));
248 if (!NILP (val)) 250 if (!NILP (val))
249 break; 251 break;
250 args = XCDR (args); 252 args = XCDR (args);
@@ -268,7 +270,7 @@ usage: (and CONDITIONS...) */)
268 270
269 while (CONSP (args)) 271 while (CONSP (args))
270 { 272 {
271 val = Feval (XCAR (args)); 273 val = eval_sub (XCAR (args));
272 if (NILP (val)) 274 if (NILP (val))
273 break; 275 break;
274 args = XCDR (args); 276 args = XCDR (args);
@@ -290,11 +292,11 @@ usage: (if COND THEN ELSE...) */)
290 struct gcpro gcpro1; 292 struct gcpro gcpro1;
291 293
292 GCPRO1 (args); 294 GCPRO1 (args);
293 cond = Feval (Fcar (args)); 295 cond = eval_sub (Fcar (args));
294 UNGCPRO; 296 UNGCPRO;
295 297
296 if (!NILP (cond)) 298 if (!NILP (cond))
297 return Feval (Fcar (Fcdr (args))); 299 return eval_sub (Fcar (Fcdr (args)));
298 return Fprogn (Fcdr (Fcdr (args))); 300 return Fprogn (Fcdr (Fcdr (args)));
299} 301}
300 302
@@ -318,7 +320,7 @@ usage: (cond CLAUSES...) */)
318 while (!NILP (args)) 320 while (!NILP (args))
319 { 321 {
320 clause = Fcar (args); 322 clause = Fcar (args);
321 val = Feval (Fcar (clause)); 323 val = eval_sub (Fcar (clause));
322 if (!NILP (val)) 324 if (!NILP (val))
323 { 325 {
324 if (!EQ (XCDR (clause), Qnil)) 326 if (!EQ (XCDR (clause), Qnil))
@@ -344,7 +346,7 @@ usage: (progn BODY...) */)
344 346
345 while (CONSP (args)) 347 while (CONSP (args))
346 { 348 {
347 val = Feval (XCAR (args)); 349 val = eval_sub (XCAR (args));
348 args = XCDR (args); 350 args = XCDR (args);
349 } 351 }
350 352
@@ -373,13 +375,12 @@ usage: (prog1 FIRST BODY...) */)
373 375
374 do 376 do
375 { 377 {
378 Lisp_Object tem = eval_sub (XCAR (args_left));
376 if (!(argnum++)) 379 if (!(argnum++))
377 val = Feval (Fcar (args_left)); 380 val = tem;
378 else 381 args_left = XCDR (args_left);
379 Feval (Fcar (args_left));
380 args_left = Fcdr (args_left);
381 } 382 }
382 while (!NILP(args_left)); 383 while (CONSP (args_left));
383 384
384 UNGCPRO; 385 UNGCPRO;
385 return val; 386 return val;
@@ -408,13 +409,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */)
408 409
409 do 410 do
410 { 411 {
412 Lisp_Object tem = eval_sub (XCAR (args_left));
411 if (!(argnum++)) 413 if (!(argnum++))
412 val = Feval (Fcar (args_left)); 414 val = tem;
413 else 415 args_left = XCDR (args_left);
414 Feval (Fcar (args_left));
415 args_left = Fcdr (args_left);
416 } 416 }
417 while (!NILP (args_left)); 417 while (CONSP (args_left));
418 418
419 UNGCPRO; 419 UNGCPRO;
420 return val; 420 return val;
@@ -432,7 +432,7 @@ usage: (setq [SYM VAL]...) */)
432 (Lisp_Object args) 432 (Lisp_Object args)
433{ 433{
434 register Lisp_Object args_left; 434 register Lisp_Object args_left;
435 register Lisp_Object val, sym; 435 register Lisp_Object val, sym, lex_binding;
436 struct gcpro gcpro1; 436 struct gcpro gcpro1;
437 437
438 if (NILP (args)) 438 if (NILP (args))
@@ -443,9 +443,19 @@ usage: (setq [SYM VAL]...) */)
443 443
444 do 444 do
445 { 445 {
446 val = Feval (Fcar (Fcdr (args_left))); 446 val = eval_sub (Fcar (Fcdr (args_left)));
447 sym = Fcar (args_left); 447 sym = Fcar (args_left);
448 Fset (sym, val); 448
449 /* Like for eval_sub, we do not check declared_special here since
450 it's been done when let-binding. */
451 if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
452 && SYMBOLP (sym)
453 && !NILP (lex_binding
454 = Fassq (sym, Vinternal_interpreter_environment)))
455 XSETCDR (lex_binding, val); /* SYM is lexically bound. */
456 else
457 Fset (sym, val); /* SYM is dynamically bound. */
458
449 args_left = Fcdr (Fcdr (args_left)); 459 args_left = Fcdr (Fcdr (args_left));
450 } 460 }
451 while (!NILP(args_left)); 461 while (!NILP(args_left));
@@ -471,9 +481,21 @@ In byte compilation, `function' causes its argument to be compiled.
471usage: (function ARG) */) 481usage: (function ARG) */)
472 (Lisp_Object args) 482 (Lisp_Object args)
473{ 483{
484 Lisp_Object quoted = XCAR (args);
485
474 if (!NILP (Fcdr (args))) 486 if (!NILP (Fcdr (args)))
475 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); 487 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
476 return Fcar (args); 488
489 if (!NILP (Vinternal_interpreter_environment)
490 && CONSP (quoted)
491 && EQ (XCAR (quoted), Qlambda))
492 /* This is a lambda expression within a lexical environment;
493 return an interpreted closure instead of a simple lambda. */
494 return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
495 XCDR (quoted)));
496 else
497 /* Simply quote the argument. */
498 return quoted;
477} 499}
478 500
479 501
@@ -496,7 +518,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
496use `called-interactively-p'. */) 518use `called-interactively-p'. */)
497 (void) 519 (void)
498{ 520{
499 return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; 521 return interactive_p (1) ? Qt : Qnil;
500} 522}
501 523
502 524
@@ -589,6 +611,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
589 fn_name = Fcar (args); 611 fn_name = Fcar (args);
590 CHECK_SYMBOL (fn_name); 612 CHECK_SYMBOL (fn_name);
591 defn = Fcons (Qlambda, Fcdr (args)); 613 defn = Fcons (Qlambda, Fcdr (args));
614 if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
615 defn = Ffunction (Fcons (defn, Qnil));
592 if (!NILP (Vpurify_flag)) 616 if (!NILP (Vpurify_flag))
593 defn = Fpurecopy (defn); 617 defn = Fpurecopy (defn);
594 if (CONSP (XSYMBOL (fn_name)->function) 618 if (CONSP (XSYMBOL (fn_name)->function)
@@ -660,7 +684,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
660 tail = Fcons (lambda_list, tail); 684 tail = Fcons (lambda_list, tail);
661 else 685 else
662 tail = Fcons (lambda_list, Fcons (doc, tail)); 686 tail = Fcons (lambda_list, Fcons (doc, tail));
663 defn = Fcons (Qmacro, Fcons (Qlambda, tail)); 687
688 defn = Fcons (Qlambda, tail);
689 if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
690 defn = Ffunction (Fcons (defn, Qnil));
691 defn = Fcons (Qmacro, defn);
664 692
665 if (!NILP (Vpurify_flag)) 693 if (!NILP (Vpurify_flag))
666 defn = Fpurecopy (defn); 694 defn = Fpurecopy (defn);
@@ -720,6 +748,7 @@ The return value is BASE-VARIABLE. */)
720 error ("Don't know how to make a let-bound variable an alias"); 748 error ("Don't know how to make a let-bound variable an alias");
721 } 749 }
722 750
751 sym->declared_special = 1;
723 sym->redirect = SYMBOL_VARALIAS; 752 sym->redirect = SYMBOL_VARALIAS;
724 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); 753 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
725 sym->constant = SYMBOL_CONSTANT_P (base_variable); 754 sym->constant = SYMBOL_CONSTANT_P (base_variable);
@@ -765,6 +794,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
765 tem = Fdefault_boundp (sym); 794 tem = Fdefault_boundp (sym);
766 if (!NILP (tail)) 795 if (!NILP (tail))
767 { 796 {
797 /* Do it before evaluating the initial value, for self-references. */
798 XSYMBOL (sym)->declared_special = 1;
799
768 if (SYMBOL_CONSTANT_P (sym)) 800 if (SYMBOL_CONSTANT_P (sym))
769 { 801 {
770 /* For upward compatibility, allow (defvar :foo (quote :foo)). */ 802 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
@@ -778,7 +810,7 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
778 } 810 }
779 811
780 if (NILP (tem)) 812 if (NILP (tem))
781 Fset_default (sym, Feval (Fcar (tail))); 813 Fset_default (sym, eval_sub (Fcar (tail)));
782 else 814 else
783 { /* Check if there is really a global binding rather than just a let 815 { /* Check if there is really a global binding rather than just a let
784 binding that shadows the global unboundness of the var. */ 816 binding that shadows the global unboundness of the var. */
@@ -804,6 +836,13 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
804 } 836 }
805 LOADHIST_ATTACH (sym); 837 LOADHIST_ATTACH (sym);
806 } 838 }
839 else if (!NILP (Vinternal_interpreter_environment)
840 && !XSYMBOL (sym)->declared_special)
841 /* A simple (defvar foo) with lexical scoping does "nothing" except
842 declare that var to be dynamically scoped *locally* (i.e. within
843 the current file or let-block). */
844 Vinternal_interpreter_environment =
845 Fcons (sym, Vinternal_interpreter_environment);
807 else 846 else
808 { 847 {
809 /* Simple (defvar <var>) should not count as a definition at all. 848 /* Simple (defvar <var>) should not count as a definition at all.
@@ -834,10 +873,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
834 if (!NILP (Fcdr (Fcdr (Fcdr (args))))) 873 if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
835 error ("Too many arguments"); 874 error ("Too many arguments");
836 875
837 tem = Feval (Fcar (Fcdr (args))); 876 tem = eval_sub (Fcar (Fcdr (args)));
838 if (!NILP (Vpurify_flag)) 877 if (!NILP (Vpurify_flag))
839 tem = Fpurecopy (tem); 878 tem = Fpurecopy (tem);
840 Fset_default (sym, tem); 879 Fset_default (sym, tem);
880 XSYMBOL (sym)->declared_special = 1;
841 tem = Fcar (Fcdr (Fcdr (args))); 881 tem = Fcar (Fcdr (Fcdr (args)));
842 if (!NILP (tem)) 882 if (!NILP (tem))
843 { 883 {
@@ -924,27 +964,53 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.
924usage: (let* VARLIST BODY...) */) 964usage: (let* VARLIST BODY...) */)
925 (Lisp_Object args) 965 (Lisp_Object args)
926{ 966{
927 Lisp_Object varlist, val, elt; 967 Lisp_Object varlist, var, val, elt, lexenv;
928 int count = SPECPDL_INDEX (); 968 int count = SPECPDL_INDEX ();
929 struct gcpro gcpro1, gcpro2, gcpro3; 969 struct gcpro gcpro1, gcpro2, gcpro3;
930 970
931 GCPRO3 (args, elt, varlist); 971 GCPRO3 (args, elt, varlist);
932 972
973 lexenv = Vinternal_interpreter_environment;
974
933 varlist = Fcar (args); 975 varlist = Fcar (args);
934 while (!NILP (varlist)) 976 while (CONSP (varlist))
935 { 977 {
936 QUIT; 978 QUIT;
937 elt = Fcar (varlist); 979
980 elt = XCAR (varlist);
938 if (SYMBOLP (elt)) 981 if (SYMBOLP (elt))
939 specbind (elt, Qnil); 982 {
983 var = elt;
984 val = Qnil;
985 }
940 else if (! NILP (Fcdr (Fcdr (elt)))) 986 else if (! NILP (Fcdr (Fcdr (elt))))
941 signal_error ("`let' bindings can have only one value-form", elt); 987 signal_error ("`let' bindings can have only one value-form", elt);
942 else 988 else
943 { 989 {
944 val = Feval (Fcar (Fcdr (elt))); 990 var = Fcar (elt);
945 specbind (Fcar (elt), val); 991 val = eval_sub (Fcar (Fcdr (elt)));
992 }
993
994 if (!NILP (lexenv) && SYMBOLP (var)
995 && !XSYMBOL (var)->declared_special
996 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
997 /* Lexically bind VAR by adding it to the interpreter's binding
998 alist. */
999 {
1000 Lisp_Object newenv
1001 = Fcons (Fcons (var, val), Vinternal_interpreter_environment);
1002 if (EQ (Vinternal_interpreter_environment, lexenv))
1003 /* Save the old lexical environment on the specpdl stack,
1004 but only for the first lexical binding, since we'll never
1005 need to revert to one of the intermediate ones. */
1006 specbind (Qinternal_interpreter_environment, newenv);
1007 else
1008 Vinternal_interpreter_environment = newenv;
946 } 1009 }
947 varlist = Fcdr (varlist); 1010 else
1011 specbind (var, val);
1012
1013 varlist = XCDR (varlist);
948 } 1014 }
949 UNGCPRO; 1015 UNGCPRO;
950 val = Fprogn (Fcdr (args)); 1016 val = Fprogn (Fcdr (args));
@@ -960,7 +1026,7 @@ All the VALUEFORMs are evalled before any symbols are bound.
960usage: (let VARLIST BODY...) */) 1026usage: (let VARLIST BODY...) */)
961 (Lisp_Object args) 1027 (Lisp_Object args)
962{ 1028{
963 Lisp_Object *temps, tem; 1029 Lisp_Object *temps, tem, lexenv;
964 register Lisp_Object elt, varlist; 1030 register Lisp_Object elt, varlist;
965 int count = SPECPDL_INDEX (); 1031 int count = SPECPDL_INDEX ();
966 register size_t argnum; 1032 register size_t argnum;
@@ -987,22 +1053,36 @@ usage: (let VARLIST BODY...) */)
987 else if (! NILP (Fcdr (Fcdr (elt)))) 1053 else if (! NILP (Fcdr (Fcdr (elt))))
988 signal_error ("`let' bindings can have only one value-form", elt); 1054 signal_error ("`let' bindings can have only one value-form", elt);
989 else 1055 else
990 temps [argnum++] = Feval (Fcar (Fcdr (elt))); 1056 temps [argnum++] = eval_sub (Fcar (Fcdr (elt)));
991 gcpro2.nvars = argnum; 1057 gcpro2.nvars = argnum;
992 } 1058 }
993 UNGCPRO; 1059 UNGCPRO;
994 1060
1061 lexenv = Vinternal_interpreter_environment;
1062
995 varlist = Fcar (args); 1063 varlist = Fcar (args);
996 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) 1064 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
997 { 1065 {
1066 Lisp_Object var;
1067
998 elt = XCAR (varlist); 1068 elt = XCAR (varlist);
1069 var = SYMBOLP (elt) ? elt : Fcar (elt);
999 tem = temps[argnum++]; 1070 tem = temps[argnum++];
1000 if (SYMBOLP (elt)) 1071
1001 specbind (elt, tem); 1072 if (!NILP (lexenv) && SYMBOLP (var)
1073 && !XSYMBOL (var)->declared_special
1074 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
1075 /* Lexically bind VAR by adding it to the lexenv alist. */
1076 lexenv = Fcons (Fcons (var, tem), lexenv);
1002 else 1077 else
1003 specbind (Fcar (elt), tem); 1078 /* Dynamically bind VAR. */
1079 specbind (var, tem);
1004 } 1080 }
1005 1081
1082 if (!EQ (lexenv, Vinternal_interpreter_environment))
1083 /* Instantiate a new lexical environment. */
1084 specbind (Qinternal_interpreter_environment, lexenv);
1085
1006 elt = Fprogn (Fcdr (args)); 1086 elt = Fprogn (Fcdr (args));
1007 SAFE_FREE (); 1087 SAFE_FREE ();
1008 return unbind_to (count, elt); 1088 return unbind_to (count, elt);
@@ -1022,7 +1102,7 @@ usage: (while TEST BODY...) */)
1022 1102
1023 test = Fcar (args); 1103 test = Fcar (args);
1024 body = Fcdr (args); 1104 body = Fcdr (args);
1025 while (!NILP (Feval (test))) 1105 while (!NILP (eval_sub (test)))
1026 { 1106 {
1027 QUIT; 1107 QUIT;
1028 Fprogn (body); 1108 Fprogn (body);
@@ -1124,7 +1204,7 @@ usage: (catch TAG BODY...) */)
1124 struct gcpro gcpro1; 1204 struct gcpro gcpro1;
1125 1205
1126 GCPRO1 (args); 1206 GCPRO1 (args);
1127 tag = Feval (Fcar (args)); 1207 tag = eval_sub (Fcar (args));
1128 UNGCPRO; 1208 UNGCPRO;
1129 return internal_catch (tag, Fprogn, Fcdr (args)); 1209 return internal_catch (tag, Fprogn, Fcdr (args));
1130} 1210}
@@ -1254,7 +1334,7 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1254 int count = SPECPDL_INDEX (); 1334 int count = SPECPDL_INDEX ();
1255 1335
1256 record_unwind_protect (Fprogn, Fcdr (args)); 1336 record_unwind_protect (Fprogn, Fcdr (args));
1257 val = Feval (Fcar (args)); 1337 val = eval_sub (Fcar (args));
1258 return unbind_to (count, val); 1338 return unbind_to (count, val);
1259} 1339}
1260 1340
@@ -1355,7 +1435,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1355 h.tag = &c; 1435 h.tag = &c;
1356 handlerlist = &h; 1436 handlerlist = &h;
1357 1437
1358 val = Feval (bodyform); 1438 val = eval_sub (bodyform);
1359 catchlist = c.next; 1439 catchlist = c.next;
1360 handlerlist = h.next; 1440 handlerlist = h.next;
1361 return val; 1441 return val;
@@ -1999,9 +2079,12 @@ then strings and vectors are not accepted. */)
1999 if (!CONSP (fun)) 2079 if (!CONSP (fun))
2000 return Qnil; 2080 return Qnil;
2001 funcar = XCAR (fun); 2081 funcar = XCAR (fun);
2002 if (EQ (funcar, Qlambda)) 2082 if (EQ (funcar, Qclosure))
2083 return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
2084 ? Qt : if_prop);
2085 else if (EQ (funcar, Qlambda))
2003 return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; 2086 return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
2004 if (EQ (funcar, Qautoload)) 2087 else if (EQ (funcar, Qautoload))
2005 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; 2088 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
2006 else 2089 else
2007 return Qnil; 2090 return Qnil;
@@ -2119,9 +2202,21 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname)
2119} 2202}
2120 2203
2121 2204
2122DEFUN ("eval", Feval, Seval, 1, 1, 0, 2205DEFUN ("eval", Feval, Seval, 1, 2, 0,
2123 doc: /* Evaluate FORM and return its value. */) 2206 doc: /* Evaluate FORM and return its value.
2124 (Lisp_Object form) 2207If LEXICAL is t, evaluate using lexical scoping. */)
2208 (Lisp_Object form, Lisp_Object lexical)
2209{
2210 int count = SPECPDL_INDEX ();
2211 specbind (Qinternal_interpreter_environment,
2212 NILP (lexical) ? Qnil : Fcons (Qt, Qnil));
2213 return unbind_to (count, eval_sub (form));
2214}
2215
2216/* Eval a sub-expression of the current expression (i.e. in the same
2217 lexical scope). */
2218Lisp_Object
2219eval_sub (Lisp_Object form)
2125{ 2220{
2126 Lisp_Object fun, val, original_fun, original_args; 2221 Lisp_Object fun, val, original_fun, original_args;
2127 Lisp_Object funcar; 2222 Lisp_Object funcar;
@@ -2132,7 +2227,20 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2132 abort (); 2227 abort ();
2133 2228
2134 if (SYMBOLP (form)) 2229 if (SYMBOLP (form))
2135 return Fsymbol_value (form); 2230 {
2231 /* Look up its binding in the lexical environment.
2232 We do not pay attention to the declared_special flag here, since we
2233 already did that when let-binding the variable. */
2234 Lisp_Object lex_binding
2235 = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
2236 ? Fassq (form, Vinternal_interpreter_environment)
2237 : Qnil;
2238 if (CONSP (lex_binding))
2239 return XCDR (lex_binding);
2240 else
2241 return Fsymbol_value (form);
2242 }
2243
2136 if (!CONSP (form)) 2244 if (!CONSP (form))
2137 return form; 2245 return form;
2138 2246
@@ -2216,7 +2324,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2216 2324
2217 while (!NILP (args_left)) 2325 while (!NILP (args_left))
2218 { 2326 {
2219 vals[argnum++] = Feval (Fcar (args_left)); 2327 vals[argnum++] = eval_sub (Fcar (args_left));
2220 args_left = Fcdr (args_left); 2328 args_left = Fcdr (args_left);
2221 gcpro3.nvars = argnum; 2329 gcpro3.nvars = argnum;
2222 } 2330 }
@@ -2237,7 +2345,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2237 maxargs = XSUBR (fun)->max_args; 2345 maxargs = XSUBR (fun)->max_args;
2238 for (i = 0; i < maxargs; args_left = Fcdr (args_left)) 2346 for (i = 0; i < maxargs; args_left = Fcdr (args_left))
2239 { 2347 {
2240 argvals[i] = Feval (Fcar (args_left)); 2348 argvals[i] = eval_sub (Fcar (args_left));
2241 gcpro3.nvars = ++i; 2349 gcpro3.nvars = ++i;
2242 } 2350 }
2243 2351
@@ -2297,7 +2405,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2297 } 2405 }
2298 } 2406 }
2299 else if (COMPILEDP (fun)) 2407 else if (COMPILEDP (fun))
2300 val = apply_lambda (fun, original_args, 1); 2408 val = apply_lambda (fun, original_args);
2301 else 2409 else
2302 { 2410 {
2303 if (EQ (fun, Qunbound)) 2411 if (EQ (fun, Qunbound))
@@ -2313,9 +2421,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2313 goto retry; 2421 goto retry;
2314 } 2422 }
2315 if (EQ (funcar, Qmacro)) 2423 if (EQ (funcar, Qmacro))
2316 val = Feval (apply1 (Fcdr (fun), original_args)); 2424 val = eval_sub (apply1 (Fcdr (fun), original_args));
2317 else if (EQ (funcar, Qlambda)) 2425 else if (EQ (funcar, Qlambda)
2318 val = apply_lambda (fun, original_args, 1); 2426 || EQ (funcar, Qclosure))
2427 val = apply_lambda (fun, original_args);
2319 else 2428 else
2320 xsignal1 (Qinvalid_function, original_fun); 2429 xsignal1 (Qinvalid_function, original_fun);
2321 } 2430 }
@@ -2786,6 +2895,39 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2786 2895
2787/* The caller should GCPRO all the elements of ARGS. */ 2896/* The caller should GCPRO all the elements of ARGS. */
2788 2897
2898DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
2899 doc: /* Non-nil if OBJECT is a function. */)
2900 (Lisp_Object object)
2901{
2902 if (SYMBOLP (object) && !NILP (Ffboundp (object)))
2903 {
2904 object = Findirect_function (object, Qt);
2905
2906 if (CONSP (object) && EQ (XCAR (object), Qautoload))
2907 {
2908 /* Autoloaded symbols are functions, except if they load
2909 macros or keymaps. */
2910 int i;
2911 for (i = 0; i < 4 && CONSP (object); i++)
2912 object = XCDR (object);
2913
2914 return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt;
2915 }
2916 }
2917
2918 if (SUBRP (object))
2919 return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil;
2920 else if (COMPILEDP (object))
2921 return Qt;
2922 else if (CONSP (object))
2923 {
2924 Lisp_Object car = XCAR (object);
2925 return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil;
2926 }
2927 else
2928 return Qnil;
2929}
2930
2789DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, 2931DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
2790 doc: /* Call first argument as a function, passing remaining arguments to it. 2932 doc: /* Call first argument as a function, passing remaining arguments to it.
2791Return the value that function returns. 2933Return the value that function returns.
@@ -2930,7 +3072,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2930 funcar = XCAR (fun); 3072 funcar = XCAR (fun);
2931 if (!SYMBOLP (funcar)) 3073 if (!SYMBOLP (funcar))
2932 xsignal1 (Qinvalid_function, original_fun); 3074 xsignal1 (Qinvalid_function, original_fun);
2933 if (EQ (funcar, Qlambda)) 3075 if (EQ (funcar, Qlambda)
3076 || EQ (funcar, Qclosure))
2934 val = funcall_lambda (fun, numargs, args + 1); 3077 val = funcall_lambda (fun, numargs, args + 1);
2935 else if (EQ (funcar, Qautoload)) 3078 else if (EQ (funcar, Qautoload))
2936 { 3079 {
@@ -2950,7 +3093,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2950} 3093}
2951 3094
2952static Lisp_Object 3095static Lisp_Object
2953apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) 3096apply_lambda (Lisp_Object fun, Lisp_Object args)
2954{ 3097{
2955 Lisp_Object args_left; 3098 Lisp_Object args_left;
2956 size_t numargs; 3099 size_t numargs;
@@ -2970,18 +3113,15 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag)
2970 for (i = 0; i < numargs; ) 3113 for (i = 0; i < numargs; )
2971 { 3114 {
2972 tem = Fcar (args_left), args_left = Fcdr (args_left); 3115 tem = Fcar (args_left), args_left = Fcdr (args_left);
2973 if (eval_flag) tem = Feval (tem); 3116 tem = eval_sub (tem);
2974 arg_vector[i++] = tem; 3117 arg_vector[i++] = tem;
2975 gcpro1.nvars = i; 3118 gcpro1.nvars = i;
2976 } 3119 }
2977 3120
2978 UNGCPRO; 3121 UNGCPRO;
2979 3122
2980 if (eval_flag) 3123 backtrace_list->args = arg_vector;
2981 { 3124 backtrace_list->nargs = i;
2982 backtrace_list->args = arg_vector;
2983 backtrace_list->nargs = i;
2984 }
2985 backtrace_list->evalargs = 0; 3125 backtrace_list->evalargs = 0;
2986 tem = funcall_lambda (fun, numargs, arg_vector); 3126 tem = funcall_lambda (fun, numargs, arg_vector);
2987 3127
@@ -3002,13 +3142,21 @@ static Lisp_Object
3002funcall_lambda (Lisp_Object fun, size_t nargs, 3142funcall_lambda (Lisp_Object fun, size_t nargs,
3003 register Lisp_Object *arg_vector) 3143 register Lisp_Object *arg_vector)
3004{ 3144{
3005 Lisp_Object val, syms_left, next; 3145 Lisp_Object val, syms_left, next, lexenv;
3006 int count = SPECPDL_INDEX (); 3146 int count = SPECPDL_INDEX ();
3007 size_t i; 3147 size_t i;
3008 int optional, rest; 3148 int optional, rest;
3009 3149
3010 if (CONSP (fun)) 3150 if (CONSP (fun))
3011 { 3151 {
3152 if (EQ (XCAR (fun), Qclosure))
3153 {
3154 fun = XCDR (fun); /* Drop `closure'. */
3155 lexenv = XCAR (fun);
3156 CHECK_LIST_CONS (fun, fun);
3157 }
3158 else
3159 lexenv = Qnil;
3012 syms_left = XCDR (fun); 3160 syms_left = XCDR (fun);
3013 if (CONSP (syms_left)) 3161 if (CONSP (syms_left))
3014 syms_left = XCAR (syms_left); 3162 syms_left = XCAR (syms_left);
@@ -3016,7 +3164,30 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
3016 xsignal1 (Qinvalid_function, fun); 3164 xsignal1 (Qinvalid_function, fun);
3017 } 3165 }
3018 else if (COMPILEDP (fun)) 3166 else if (COMPILEDP (fun))
3019 syms_left = AREF (fun, COMPILED_ARGLIST); 3167 {
3168 syms_left = AREF (fun, COMPILED_ARGLIST);
3169 if (INTEGERP (syms_left))
3170 /* A byte-code object with a non-nil `push args' slot means we
3171 shouldn't bind any arguments, instead just call the byte-code
3172 interpreter directly; it will push arguments as necessary.
3173
3174 Byte-code objects with either a non-existant, or a nil value for
3175 the `push args' slot (the default), have dynamically-bound
3176 arguments, and use the argument-binding code below instead (as do
3177 all interpreted functions, even lexically bound ones). */
3178 {
3179 /* If we have not actually read the bytecode string
3180 and constants vector yet, fetch them from the file. */
3181 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3182 Ffetch_bytecode (fun);
3183 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3184 AREF (fun, COMPILED_CONSTANTS),
3185 AREF (fun, COMPILED_STACK_DEPTH),
3186 syms_left,
3187 nargs, arg_vector);
3188 }
3189 lexenv = Qnil;
3190 }
3020 else 3191 else
3021 abort (); 3192 abort ();
3022 3193
@@ -3033,17 +3204,29 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
3033 rest = 1; 3204 rest = 1;
3034 else if (EQ (next, Qand_optional)) 3205 else if (EQ (next, Qand_optional))
3035 optional = 1; 3206 optional = 1;
3036 else if (rest) 3207 else
3037 { 3208 {
3038 specbind (next, Flist (nargs - i, &arg_vector[i])); 3209 Lisp_Object val;
3039 i = nargs; 3210 if (rest)
3211 {
3212 val = Flist (nargs - i, &arg_vector[i]);
3213 i = nargs;
3214 }
3215 else if (i < nargs)
3216 val = arg_vector[i++];
3217 else if (!optional)
3218 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3219 else
3220 val = Qnil;
3221
3222 /* Bind the argument. */
3223 if (!NILP (lexenv) && SYMBOLP (next))
3224 /* Lexically bind NEXT by adding it to the lexenv alist. */
3225 lexenv = Fcons (Fcons (next, val), lexenv);
3226 else
3227 /* Dynamically bind NEXT. */
3228 specbind (next, val);
3040 } 3229 }
3041 else if (i < nargs)
3042 specbind (next, arg_vector[i++]);
3043 else if (!optional)
3044 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3045 else
3046 specbind (next, Qnil);
3047 } 3230 }
3048 3231
3049 if (!NILP (syms_left)) 3232 if (!NILP (syms_left))
@@ -3051,6 +3234,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
3051 else if (i < nargs) 3234 else if (i < nargs)
3052 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); 3235 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3053 3236
3237 if (!EQ (lexenv, Vinternal_interpreter_environment))
3238 /* Instantiate a new lexical environment. */
3239 specbind (Qinternal_interpreter_environment, lexenv);
3240
3054 if (CONSP (fun)) 3241 if (CONSP (fun))
3055 val = Fprogn (XCDR (XCDR (fun))); 3242 val = Fprogn (XCDR (XCDR (fun)));
3056 else 3243 else
@@ -3059,9 +3246,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
3059 and constants vector yet, fetch them from the file. */ 3246 and constants vector yet, fetch them from the file. */
3060 if (CONSP (AREF (fun, COMPILED_BYTECODE))) 3247 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3061 Ffetch_bytecode (fun); 3248 Ffetch_bytecode (fun);
3062 val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), 3249 val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3063 AREF (fun, COMPILED_CONSTANTS), 3250 AREF (fun, COMPILED_CONSTANTS),
3064 AREF (fun, COMPILED_STACK_DEPTH)); 3251 AREF (fun, COMPILED_STACK_DEPTH),
3252 Qnil, 0, 0);
3065 } 3253 }
3066 3254
3067 return unbind_to (count, val); 3255 return unbind_to (count, val);
@@ -3297,6 +3485,17 @@ unbind_to (int count, Lisp_Object value)
3297 UNGCPRO; 3485 UNGCPRO;
3298 return value; 3486 return value;
3299} 3487}
3488
3489DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
3490 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3491A special variable is one that will be bound dynamically, even in a
3492context where binding is lexical by default. */)
3493 (Lisp_Object symbol)
3494{
3495 CHECK_SYMBOL (symbol);
3496 return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
3497}
3498
3300 3499
3301DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, 3500DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3302 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. 3501 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
@@ -3437,6 +3636,8 @@ mark_backtrace (void)
3437 } 3636 }
3438} 3637}
3439 3638
3639EXFUN (Funintern, 2);
3640
3440void 3641void
3441syms_of_eval (void) 3642syms_of_eval (void)
3442{ 3643{
@@ -3509,6 +3710,9 @@ before making `inhibit-quit' nil. */);
3509 Qand_optional = intern_c_string ("&optional"); 3710 Qand_optional = intern_c_string ("&optional");
3510 staticpro (&Qand_optional); 3711 staticpro (&Qand_optional);
3511 3712
3713 Qclosure = intern_c_string ("closure");
3714 staticpro (&Qclosure);
3715
3512 Qdebug = intern_c_string ("debug"); 3716 Qdebug = intern_c_string ("debug");
3513 staticpro (&Qdebug); 3717 staticpro (&Qdebug);
3514 3718
@@ -3576,6 +3780,28 @@ DECL is a list `(declare ...)' containing the declarations.
3576The value the function returns is not used. */); 3780The value the function returns is not used. */);
3577 Vmacro_declaration_function = Qnil; 3781 Vmacro_declaration_function = Qnil;
3578 3782
3783 /* When lexical binding is being used,
3784 vinternal_interpreter_environment is non-nil, and contains an alist
3785 of lexically-bound variable, or (t), indicating an empty
3786 environment. The lisp name of this variable would be
3787 `internal-interpreter-environment' if it weren't hidden.
3788 Every element of this list can be either a cons (VAR . VAL)
3789 specifying a lexical binding, or a single symbol VAR indicating
3790 that this variable should use dynamic scoping. */
3791 Qinternal_interpreter_environment
3792 = intern_c_string ("internal-interpreter-environment");
3793 staticpro (&Qinternal_interpreter_environment);
3794 DEFVAR_LISP ("internal-interpreter-environment",
3795 Vinternal_interpreter_environment,
3796 doc: /* If non-nil, the current lexical environment of the lisp interpreter.
3797When lexical binding is not being used, this variable is nil.
3798A value of `(t)' indicates an empty environment, otherwise it is an
3799alist of active lexical bindings. */);
3800 Vinternal_interpreter_environment = Qnil;
3801 /* Don't export this variable to Elisp, so noone can mess with it
3802 (Just imagine if someone makes it buffer-local). */
3803 Funintern (Qinternal_interpreter_environment, Qnil);
3804
3579 Vrun_hooks = intern_c_string ("run-hooks"); 3805 Vrun_hooks = intern_c_string ("run-hooks");
3580 staticpro (&Vrun_hooks); 3806 staticpro (&Vrun_hooks);
3581 3807
@@ -3625,4 +3851,6 @@ The value the function returns is not used. */);
3625 defsubr (&Sbacktrace_debug); 3851 defsubr (&Sbacktrace_debug);
3626 defsubr (&Sbacktrace); 3852 defsubr (&Sbacktrace);
3627 defsubr (&Sbacktrace_frame); 3853 defsubr (&Sbacktrace_frame);
3854 defsubr (&Sspecial_variable_p);
3855 defsubr (&Sfunctionp);
3628} 3856}
diff --git a/src/fns.c b/src/fns.c
index 95e8badbaa5..bce922859d1 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -510,7 +510,7 @@ concat (size_t nargs, Lisp_Object *args,
510 Lisp_Object ch; 510 Lisp_Object ch;
511 EMACS_INT this_len_byte; 511 EMACS_INT this_len_byte;
512 512
513 if (VECTORP (this)) 513 if (VECTORP (this) || COMPILEDP (this))
514 for (i = 0; i < len; i++) 514 for (i = 0; i < len; i++)
515 { 515 {
516 ch = AREF (this, i); 516 ch = AREF (this, i);
@@ -2297,7 +2297,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2297 1) lists are not relocated and 2) the list is marked via `seq' so will not 2297 1) lists are not relocated and 2) the list is marked via `seq' so will not
2298 be freed */ 2298 be freed */
2299 2299
2300 if (VECTORP (seq)) 2300 if (VECTORP (seq) || COMPILEDP (seq))
2301 { 2301 {
2302 for (i = 0; i < leni; i++) 2302 for (i = 0; i < leni; i++)
2303 { 2303 {
diff --git a/src/image.c b/src/image.c
index 25929d1004c..b37ba398d83 100644
--- a/src/image.c
+++ b/src/image.c
@@ -831,9 +831,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
831 831
832 case IMAGE_FUNCTION_VALUE: 832 case IMAGE_FUNCTION_VALUE:
833 value = indirect_function (value); 833 value = indirect_function (value);
834 if (SUBRP (value) 834 if (!NILP (Ffunctionp (value)))
835 || COMPILEDP (value)
836 || (CONSP (value) && EQ (XCAR (value), Qlambda)))
837 break; 835 break;
838 return 0; 836 return 0;
839 837
diff --git a/src/keyboard.c b/src/keyboard.c
index 70098d46ebb..d307250b868 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1134,7 +1134,7 @@ command_loop_2 (Lisp_Object ignore)
1134static Lisp_Object 1134static Lisp_Object
1135top_level_2 (void) 1135top_level_2 (void)
1136{ 1136{
1137 return Feval (Vtop_level); 1137 return Feval (Vtop_level, Qnil);
1138} 1138}
1139 1139
1140Lisp_Object 1140Lisp_Object
@@ -3095,7 +3095,7 @@ read_char (int commandflag, int nmaps, Lisp_Object *maps, Lisp_Object prev_event
3095 help_form_saved_window_configs); 3095 help_form_saved_window_configs);
3096 record_unwind_protect (read_char_help_form_unwind, Qnil); 3096 record_unwind_protect (read_char_help_form_unwind, Qnil);
3097 3097
3098 tem0 = Feval (Vhelp_form); 3098 tem0 = Feval (Vhelp_form, Qnil);
3099 if (STRINGP (tem0)) 3099 if (STRINGP (tem0))
3100 internal_with_output_to_temp_buffer ("*Help*", print_help, tem0); 3100 internal_with_output_to_temp_buffer ("*Help*", print_help, tem0);
3101 3101
@@ -7571,6 +7571,12 @@ menu_item_eval_property_1 (Lisp_Object arg)
7571 return Qnil; 7571 return Qnil;
7572} 7572}
7573 7573
7574static Lisp_Object
7575eval_dyn (Lisp_Object form)
7576{
7577 return Feval (form, Qnil);
7578}
7579
7574/* Evaluate an expression and return the result (or nil if something 7580/* Evaluate an expression and return the result (or nil if something
7575 went wrong). Used to evaluate dynamic parts of menu items. */ 7581 went wrong). Used to evaluate dynamic parts of menu items. */
7576Lisp_Object 7582Lisp_Object
@@ -7579,7 +7585,7 @@ menu_item_eval_property (Lisp_Object sexpr)
7579 int count = SPECPDL_INDEX (); 7585 int count = SPECPDL_INDEX ();
7580 Lisp_Object val; 7586 Lisp_Object val;
7581 specbind (Qinhibit_redisplay, Qt); 7587 specbind (Qinhibit_redisplay, Qt);
7582 val = internal_condition_case_1 (Feval, sexpr, Qerror, 7588 val = internal_condition_case_1 (eval_dyn, sexpr, Qerror,
7583 menu_item_eval_property_1); 7589 menu_item_eval_property_1);
7584 return unbind_to (count, val); 7590 return unbind_to (count, val);
7585} 7591}
diff --git a/src/lisp.h b/src/lisp.h
index 63f346f6a25..dfaa3fd01f0 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1016,6 +1016,10 @@ struct Lisp_Symbol
1016 /* Interned state of the symbol. This is an enumerator from 1016 /* Interned state of the symbol. This is an enumerator from
1017 enum symbol_interned. */ 1017 enum symbol_interned. */
1018 unsigned interned : 2; 1018 unsigned interned : 2;
1019
1020 /* Non-zero means that this variable has been explicitly declared
1021 special (with `defvar' etc), and shouldn't be lexically bound. */
1022 unsigned declared_special : 1;
1019 1023
1020 /* The symbol's name, as a Lisp string. 1024 /* The symbol's name, as a Lisp string.
1021 1025
@@ -2814,7 +2818,7 @@ extern void syms_of_lread (void);
2814 2818
2815/* Defined in eval.c. */ 2819/* Defined in eval.c. */
2816extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro; 2820extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro;
2817extern Lisp_Object Qinhibit_quit; 2821extern Lisp_Object Qinhibit_quit, Qclosure;
2818extern Lisp_Object Vautoload_queue; 2822extern Lisp_Object Vautoload_queue;
2819extern Lisp_Object Vsignaling_function; 2823extern Lisp_Object Vsignaling_function;
2820extern int handling_signal; 2824extern int handling_signal;
@@ -2844,7 +2848,9 @@ extern void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
2844extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; 2848extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
2845extern void signal_error (const char *, Lisp_Object) NO_RETURN; 2849extern void signal_error (const char *, Lisp_Object) NO_RETURN;
2846EXFUN (Fcommandp, 2); 2850EXFUN (Fcommandp, 2);
2847EXFUN (Feval, 1); 2851EXFUN (Ffunctionp, 1);
2852EXFUN (Feval, 2);
2853extern Lisp_Object eval_sub (Lisp_Object form);
2848EXFUN (Fapply, MANY); 2854EXFUN (Fapply, MANY);
2849EXFUN (Ffuncall, MANY); 2855EXFUN (Ffuncall, MANY);
2850EXFUN (Fbacktrace, 0); 2856EXFUN (Fbacktrace, 0);
@@ -3264,6 +3270,8 @@ extern struct byte_stack *byte_stack_list;
3264extern void mark_byte_stack (void); 3270extern void mark_byte_stack (void);
3265#endif 3271#endif
3266extern void unmark_byte_stack (void); 3272extern void unmark_byte_stack (void);
3273extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
3274 Lisp_Object, int, Lisp_Object *);
3267 3275
3268/* Defined in macros.c */ 3276/* Defined in macros.c */
3269extern Lisp_Object Qexecute_kbd_macro; 3277extern Lisp_Object Qexecute_kbd_macro;
diff --git a/src/lread.c b/src/lread.c
index a5fd1513c39..6a24569f552 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -73,6 +73,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name;
73Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; 73Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
74Lisp_Object Qinhibit_file_name_operation; 74Lisp_Object Qinhibit_file_name_operation;
75Lisp_Object Qeval_buffer_list; 75Lisp_Object Qeval_buffer_list;
76Lisp_Object Qlexical_binding;
76Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ 77Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
77 78
78/* Used instead of Qget_file_char while loading *.elc files compiled 79/* Used instead of Qget_file_char while loading *.elc files compiled
@@ -81,6 +82,8 @@ static Lisp_Object Qget_emacs_mule_file_char;
81 82
82static Lisp_Object Qload_force_doc_strings; 83static Lisp_Object Qload_force_doc_strings;
83 84
85extern Lisp_Object Qinternal_interpreter_environment;
86
84static Lisp_Object Qload_in_progress; 87static Lisp_Object Qload_in_progress;
85 88
86/* The association list of objects read with the #n=object form. 89/* The association list of objects read with the #n=object form.
@@ -147,8 +150,7 @@ static Lisp_Object Vloads_in_progress;
147static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), 150static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
148 Lisp_Object); 151 Lisp_Object);
149 152
150static void readevalloop (Lisp_Object, FILE*, Lisp_Object, 153static void readevalloop (Lisp_Object, FILE*, Lisp_Object, int,
151 Lisp_Object (*) (Lisp_Object), int,
152 Lisp_Object, Lisp_Object, 154 Lisp_Object, Lisp_Object,
153 Lisp_Object, Lisp_Object); 155 Lisp_Object, Lisp_Object);
154static Lisp_Object load_unwind (Lisp_Object); 156static Lisp_Object load_unwind (Lisp_Object);
@@ -769,6 +771,116 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
769 771
770 772
771 773
774
775/* Return true if the lisp code read using READCHARFUN defines a non-nil
776 `lexical-binding' file variable. After returning, the stream is
777 positioned following the first line, if it is a comment, otherwise
778 nothing is read. */
779
780static int
781lisp_file_lexically_bound_p (Lisp_Object readcharfun)
782{
783 int ch = READCHAR;
784 if (ch != ';')
785 /* The first line isn't a comment, just give up. */
786 {
787 UNREAD (ch);
788 return 0;
789 }
790 else
791 /* Look for an appropriate file-variable in the first line. */
792 {
793 int rv = 0;
794 enum {
795 NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX,
796 } beg_end_state = NOMINAL;
797 int in_file_vars = 0;
798
799#define UPDATE_BEG_END_STATE(ch) \
800 if (beg_end_state == NOMINAL) \
801 beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
802 else if (beg_end_state == AFTER_FIRST_DASH) \
803 beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
804 else if (beg_end_state == AFTER_ASTERIX) \
805 { \
806 if (ch == '-') \
807 in_file_vars = !in_file_vars; \
808 beg_end_state = NOMINAL; \
809 }
810
811 /* Skip until we get to the file vars, if any. */
812 do
813 {
814 ch = READCHAR;
815 UPDATE_BEG_END_STATE (ch);
816 }
817 while (!in_file_vars && ch != '\n' && ch != EOF);
818
819 while (in_file_vars)
820 {
821 char var[100], *var_end, val[100], *val_end;
822
823 ch = READCHAR;
824
825 /* Read a variable name. */
826 while (ch == ' ' || ch == '\t')
827 ch = READCHAR;
828
829 var_end = var;
830 while (ch != ':' && ch != '\n' && ch != EOF)
831 {
832 if (var_end < var + sizeof var - 1)
833 *var_end++ = ch;
834 UPDATE_BEG_END_STATE (ch);
835 ch = READCHAR;
836 }
837
838 while (var_end > var
839 && (var_end[-1] == ' ' || var_end[-1] == '\t'))
840 var_end--;
841 *var_end = '\0';
842
843 if (ch == ':')
844 {
845 /* Read a variable value. */
846 ch = READCHAR;
847
848 while (ch == ' ' || ch == '\t')
849 ch = READCHAR;
850
851 val_end = val;
852 while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
853 {
854 if (val_end < val + sizeof val - 1)
855 *val_end++ = ch;
856 UPDATE_BEG_END_STATE (ch);
857 ch = READCHAR;
858 }
859 if (! in_file_vars)
860 /* The value was terminated by an end-marker, which
861 remove. */
862 val_end -= 3;
863 while (val_end > val
864 && (val_end[-1] == ' ' || val_end[-1] == '\t'))
865 val_end--;
866 *val_end = '\0';
867
868 if (strcmp (var, "lexical-binding") == 0)
869 /* This is it... */
870 {
871 rv = (strcmp (val, "nil") != 0);
872 break;
873 }
874 }
875 }
876
877 while (ch != '\n' && ch != EOF)
878 ch = READCHAR;
879
880 return rv;
881 }
882}
883
772/* Value is a version number of byte compiled code if the file 884/* Value is a version number of byte compiled code if the file
773 associated with file descriptor FD is a compiled Lisp file that's 885 associated with file descriptor FD is a compiled Lisp file that's
774 safe to load. Only files compiled with Emacs are safe to load. 886 safe to load. Only files compiled with Emacs are safe to load.
@@ -1033,6 +1145,12 @@ Return t if the file exists and loads successfully. */)
1033 Vloads_in_progress = Fcons (found, Vloads_in_progress); 1145 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1034 } 1146 }
1035 1147
1148 /* All loads are by default dynamic, unless the file itself specifies
1149 otherwise using a file-variable in the first line. This is bound here
1150 so that it takes effect whether or not we use
1151 Vload_source_file_function. */
1152 specbind (Qlexical_binding, Qnil);
1153
1036 /* Get the name for load-history. */ 1154 /* Get the name for load-history. */
1037 hist_file_name = (! NILP (Vpurify_flag) 1155 hist_file_name = (! NILP (Vpurify_flag)
1038 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), 1156 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
@@ -1157,15 +1275,20 @@ Return t if the file exists and loads successfully. */)
1157 load_descriptor_list 1275 load_descriptor_list
1158 = Fcons (make_number (fileno (stream)), load_descriptor_list); 1276 = Fcons (make_number (fileno (stream)), load_descriptor_list);
1159 specbind (Qload_in_progress, Qt); 1277 specbind (Qload_in_progress, Qt);
1278
1279 instream = stream;
1280 if (lisp_file_lexically_bound_p (Qget_file_char))
1281 Fset (Qlexical_binding, Qt);
1282
1160 if (! version || version >= 22) 1283 if (! version || version >= 22)
1161 readevalloop (Qget_file_char, stream, hist_file_name, 1284 readevalloop (Qget_file_char, stream, hist_file_name,
1162 Feval, 0, Qnil, Qnil, Qnil, Qnil); 1285 0, Qnil, Qnil, Qnil, Qnil);
1163 else 1286 else
1164 { 1287 {
1165 /* We can't handle a file which was compiled with 1288 /* We can't handle a file which was compiled with
1166 byte-compile-dynamic by older version of Emacs. */ 1289 byte-compile-dynamic by older version of Emacs. */
1167 specbind (Qload_force_doc_strings, Qt); 1290 specbind (Qload_force_doc_strings, Qt);
1168 readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval, 1291 readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name,
1169 0, Qnil, Qnil, Qnil, Qnil); 1292 0, Qnil, Qnil, Qnil, Qnil);
1170 } 1293 }
1171 unbind_to (count, Qnil); 1294 unbind_to (count, Qnil);
@@ -1535,7 +1658,6 @@ static void
1535readevalloop (Lisp_Object readcharfun, 1658readevalloop (Lisp_Object readcharfun,
1536 FILE *stream, 1659 FILE *stream,
1537 Lisp_Object sourcename, 1660 Lisp_Object sourcename,
1538 Lisp_Object (*evalfun) (Lisp_Object),
1539 int printflag, 1661 int printflag,
1540 Lisp_Object unibyte, Lisp_Object readfun, 1662 Lisp_Object unibyte, Lisp_Object readfun,
1541 Lisp_Object start, Lisp_Object end) 1663 Lisp_Object start, Lisp_Object end)
@@ -1546,6 +1668,7 @@ readevalloop (Lisp_Object readcharfun,
1546 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; 1668 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1547 struct buffer *b = 0; 1669 struct buffer *b = 0;
1548 int continue_reading_p; 1670 int continue_reading_p;
1671 Lisp_Object lex_bound;
1549 /* Nonzero if reading an entire buffer. */ 1672 /* Nonzero if reading an entire buffer. */
1550 int whole_buffer = 0; 1673 int whole_buffer = 0;
1551 /* 1 on the first time around. */ 1674 /* 1 on the first time around. */
@@ -1571,6 +1694,14 @@ readevalloop (Lisp_Object readcharfun,
1571 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); 1694 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
1572 load_convert_to_unibyte = !NILP (unibyte); 1695 load_convert_to_unibyte = !NILP (unibyte);
1573 1696
1697 /* If lexical binding is active (either because it was specified in
1698 the file's header, or via a buffer-local variable), create an empty
1699 lexical environment, otherwise, turn off lexical binding. */
1700 lex_bound = find_symbol_value (Qlexical_binding);
1701 specbind (Qinternal_interpreter_environment,
1702 NILP (lex_bound) || EQ (lex_bound, Qunbound)
1703 ? Qnil : Fcons (Qt, Qnil));
1704
1574 GCPRO4 (sourcename, readfun, start, end); 1705 GCPRO4 (sourcename, readfun, start, end);
1575 1706
1576 /* Try to ensure sourcename is a truename, except whilst preloading. */ 1707 /* Try to ensure sourcename is a truename, except whilst preloading. */
@@ -1672,7 +1803,7 @@ readevalloop (Lisp_Object readcharfun,
1672 unbind_to (count1, Qnil); 1803 unbind_to (count1, Qnil);
1673 1804
1674 /* Now eval what we just read. */ 1805 /* Now eval what we just read. */
1675 val = (*evalfun) (val); 1806 val = eval_sub (val);
1676 1807
1677 if (printflag) 1808 if (printflag)
1678 { 1809 {
@@ -1732,7 +1863,8 @@ This function preserves the position of point. */)
1732 specbind (Qstandard_output, tem); 1863 specbind (Qstandard_output, tem);
1733 record_unwind_protect (save_excursion_restore, save_excursion_save ()); 1864 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1734 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); 1865 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1735 readevalloop (buf, 0, filename, Feval, 1866 specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
1867 readevalloop (buf, 0, filename,
1736 !NILP (printflag), unibyte, Qnil, Qnil, Qnil); 1868 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
1737 unbind_to (count, Qnil); 1869 unbind_to (count, Qnil);
1738 1870
@@ -1753,6 +1885,7 @@ which is the input stream for reading characters.
1753This function does not move point. */) 1885This function does not move point. */)
1754 (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function) 1886 (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function)
1755{ 1887{
1888 /* FIXME: Do the eval-sexp-add-defvars danse! */
1756 int count = SPECPDL_INDEX (); 1889 int count = SPECPDL_INDEX ();
1757 Lisp_Object tem, cbuf; 1890 Lisp_Object tem, cbuf;
1758 1891
@@ -1766,7 +1899,7 @@ This function does not move point. */)
1766 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list)); 1899 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
1767 1900
1768 /* readevalloop calls functions which check the type of start and end. */ 1901 /* readevalloop calls functions which check the type of start and end. */
1769 readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), Feval, 1902 readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
1770 !NILP (printflag), Qnil, read_function, 1903 !NILP (printflag), Qnil, read_function,
1771 start, end); 1904 start, end);
1772 1905
@@ -3838,6 +3971,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd,
3838 sym = intern_c_string (namestring); 3971 sym = intern_c_string (namestring);
3839 i_fwd->type = Lisp_Fwd_Int; 3972 i_fwd->type = Lisp_Fwd_Int;
3840 i_fwd->intvar = address; 3973 i_fwd->intvar = address;
3974 XSYMBOL (sym)->declared_special = 1;
3841 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 3975 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3842 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); 3976 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
3843} 3977}
@@ -3852,6 +3986,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd,
3852 sym = intern_c_string (namestring); 3986 sym = intern_c_string (namestring);
3853 b_fwd->type = Lisp_Fwd_Bool; 3987 b_fwd->type = Lisp_Fwd_Bool;
3854 b_fwd->boolvar = address; 3988 b_fwd->boolvar = address;
3989 XSYMBOL (sym)->declared_special = 1;
3855 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 3990 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3856 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); 3991 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
3857 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); 3992 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
@@ -3870,6 +4005,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd,
3870 sym = intern_c_string (namestring); 4005 sym = intern_c_string (namestring);
3871 o_fwd->type = Lisp_Fwd_Obj; 4006 o_fwd->type = Lisp_Fwd_Obj;
3872 o_fwd->objvar = address; 4007 o_fwd->objvar = address;
4008 XSYMBOL (sym)->declared_special = 1;
3873 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4009 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3874 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); 4010 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
3875} 4011}
@@ -3893,6 +4029,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd,
3893 sym = intern_c_string (namestring); 4029 sym = intern_c_string (namestring);
3894 ko_fwd->type = Lisp_Fwd_Kboard_Obj; 4030 ko_fwd->type = Lisp_Fwd_Kboard_Obj;
3895 ko_fwd->offset = offset; 4031 ko_fwd->offset = offset;
4032 XSYMBOL (sym)->declared_special = 1;
3896 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; 4033 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
3897 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); 4034 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
3898} 4035}
@@ -4320,6 +4457,15 @@ to load. See also `load-dangerous-libraries'. */);
4320 Vbytecomp_version_regexp 4457 Vbytecomp_version_regexp
4321 = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); 4458 = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4322 4459
4460 Qlexical_binding = intern ("lexical-binding");
4461 staticpro (&Qlexical_binding);
4462 DEFVAR_LISP ("lexical-binding", Vlexical_binding,
4463 doc: /* If non-nil, use lexical binding when evaluating code.
4464This only applies to code evaluated by `eval-buffer' and `eval-region'.
4465This variable is automatically set from the file variables of an interpreted
4466 Lisp file read using `load'. */);
4467 Fmake_variable_buffer_local (Qlexical_binding);
4468
4323 DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list, 4469 DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
4324 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); 4470 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4325 Veval_buffer_list = Qnil; 4471 Veval_buffer_list = Qnil;
diff --git a/src/minibuf.c b/src/minibuf.c
index 7bed9bb2f2d..4adf665f8f4 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -971,7 +971,8 @@ Such arguments are used as in `read-from-minibuffer'.) */)
971{ 971{
972 return Feval (read_minibuf (Vread_expression_map, initial_contents, 972 return Feval (read_minibuf (Vread_expression_map, initial_contents,
973 prompt, Qnil, 1, Qread_expression_history, 973 prompt, Qnil, 1, Qread_expression_history,
974 make_number (0), Qnil, 0, 0)); 974 make_number (0), Qnil, 0, 0),
975 Qnil);
975} 976}
976 977
977/* Functions that use the minibuffer to read various things. */ 978/* Functions that use the minibuffer to read various things. */
diff --git a/src/print.c b/src/print.c
index dd3d1c9bbb2..3e0e168381b 100644
--- a/src/print.c
+++ b/src/print.c
@@ -521,6 +521,7 @@ temp_output_buffer_setup (const char *bufname)
521 specbind (Qstandard_output, buf); 521 specbind (Qstandard_output, buf);
522} 522}
523 523
524/* FIXME: Use Lisp's with-output-to-temp-buffer instead! */
524Lisp_Object 525Lisp_Object
525internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args) 526internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args)
526{ 527{
@@ -542,60 +543,6 @@ internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function
542 543
543 return unbind_to (count, val); 544 return unbind_to (count, val);
544} 545}
545
546DEFUN ("with-output-to-temp-buffer",
547 Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
548 1, UNEVALLED, 0,
549 doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
550
551This construct makes buffer BUFNAME empty before running BODY.
552It does not make the buffer current for BODY.
553Instead it binds `standard-output' to that buffer, so that output
554generated with `prin1' and similar functions in BODY goes into
555the buffer.
556
557At the end of BODY, this marks buffer BUFNAME unmodifed and displays
558it in a window, but does not select it. The normal way to do this is
559by calling `display-buffer', then running `temp-buffer-show-hook'.
560However, if `temp-buffer-show-function' is non-nil, it calls that
561function instead (and does not run `temp-buffer-show-hook'). The
562function gets one argument, the buffer to display.
563
564The return value of `with-output-to-temp-buffer' is the value of the
565last form in BODY. If BODY does not finish normally, the buffer
566BUFNAME is not displayed.
567
568This runs the hook `temp-buffer-setup-hook' before BODY,
569with the buffer BUFNAME temporarily current. It runs the hook
570`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
571buffer temporarily current, and the window that was used to display it
572temporarily selected. But it doesn't run `temp-buffer-show-hook'
573if it uses `temp-buffer-show-function'.
574
575usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
576 (Lisp_Object args)
577{
578 struct gcpro gcpro1;
579 Lisp_Object name;
580 int count = SPECPDL_INDEX ();
581 Lisp_Object buf, val;
582
583 GCPRO1(args);
584 name = Feval (Fcar (args));
585 CHECK_STRING (name);
586 temp_output_buffer_setup (SSDATA (name));
587 buf = Vstandard_output;
588 UNGCPRO;
589
590 val = Fprogn (XCDR (args));
591
592 GCPRO1 (val);
593 temp_output_buffer_show (buf);
594 UNGCPRO;
595
596 return unbind_to (count, val);
597}
598
599 546
600static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); 547static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag);
601static void print_preprocess (Lisp_Object obj); 548static void print_preprocess (Lisp_Object obj);
@@ -2289,6 +2236,4 @@ priorities. */);
2289 2236
2290 print_prune_charset_plist = Qnil; 2237 print_prune_charset_plist = Qnil;
2291 staticpro (&print_prune_charset_plist); 2238 staticpro (&print_prune_charset_plist);
2292
2293 defsubr (&Swith_output_to_temp_buffer);
2294} 2239}
diff --git a/src/window.c b/src/window.c
index 0d299b7cd93..5ca46dd3316 100644
--- a/src/window.c
+++ b/src/window.c
@@ -3705,6 +3705,16 @@ temp_output_buffer_show (register Lisp_Object buf)
3705 } 3705 }
3706 } 3706 }
3707} 3707}
3708
3709DEFUN ("internal-temp-output-buffer-show",
3710 Ftemp_output_buffer_show, Stemp_output_buffer_show,
3711 1, 1, 0,
3712 doc: /* Internal function for `with-output-to-temp-buffer''. */)
3713 (Lisp_Object buf)
3714{
3715 temp_output_buffer_show (buf);
3716 return Qnil;
3717}
3708 3718
3709static void 3719static void
3710make_dummy_parent (Lisp_Object window) 3720make_dummy_parent (Lisp_Object window)
@@ -6390,28 +6400,6 @@ redirection (see `redirect-frame-focus'). */)
6390 return (tem); 6400 return (tem);
6391} 6401}
6392 6402
6393DEFUN ("save-window-excursion", Fsave_window_excursion, Ssave_window_excursion,
6394 0, UNEVALLED, 0,
6395 doc: /* Execute BODY, preserving window sizes and contents.
6396Return the value of the last form in BODY.
6397Restore which buffer appears in which window, where display starts,
6398and the value of point and mark for each window.
6399Also restore the choice of selected window.
6400Also restore which buffer is current.
6401Does not restore the value of point in current buffer.
6402usage: (save-window-excursion BODY...) */)
6403 (Lisp_Object args)
6404{
6405 register Lisp_Object val;
6406 register int count = SPECPDL_INDEX ();
6407
6408 record_unwind_protect (Fset_window_configuration,
6409 Fcurrent_window_configuration (Qnil));
6410 val = Fprogn (args);
6411 return unbind_to (count, val);
6412}
6413
6414
6415 6403
6416/*********************************************************************** 6404/***********************************************************************
6417 Window Split Tree 6405 Window Split Tree
@@ -7167,6 +7155,7 @@ frame to be redrawn only if it is a tty frame. */);
7167 defsubr (&Sset_window_buffer); 7155 defsubr (&Sset_window_buffer);
7168 defsubr (&Sselect_window); 7156 defsubr (&Sselect_window);
7169 defsubr (&Sforce_window_update); 7157 defsubr (&Sforce_window_update);
7158 defsubr (&Stemp_output_buffer_show);
7170 defsubr (&Ssplit_window); 7159 defsubr (&Ssplit_window);
7171 defsubr (&Senlarge_window); 7160 defsubr (&Senlarge_window);
7172 defsubr (&Sshrink_window); 7161 defsubr (&Sshrink_window);
@@ -7185,7 +7174,6 @@ frame to be redrawn only if it is a tty frame. */);
7185 defsubr (&Swindow_configuration_frame); 7174 defsubr (&Swindow_configuration_frame);
7186 defsubr (&Sset_window_configuration); 7175 defsubr (&Sset_window_configuration);
7187 defsubr (&Scurrent_window_configuration); 7176 defsubr (&Scurrent_window_configuration);
7188 defsubr (&Ssave_window_excursion);
7189 defsubr (&Swindow_tree); 7177 defsubr (&Swindow_tree);
7190 defsubr (&Sset_window_margins); 7178 defsubr (&Sset_window_margins);
7191 defsubr (&Swindow_margins); 7179 defsubr (&Swindow_margins);
diff --git a/src/window.h b/src/window.h
index f788e126d6d..ad627aca340 100644
--- a/src/window.h
+++ b/src/window.h
@@ -853,7 +853,6 @@ EXFUN (Fwindow_minibuffer_p, 1);
853EXFUN (Fdelete_window, 1); 853EXFUN (Fdelete_window, 1);
854EXFUN (Fwindow_buffer, 1); 854EXFUN (Fwindow_buffer, 1);
855EXFUN (Fget_buffer_window, 2); 855EXFUN (Fget_buffer_window, 2);
856EXFUN (Fsave_window_excursion, UNEVALLED);
857EXFUN (Fset_window_configuration, 1); 856EXFUN (Fset_window_configuration, 1);
858EXFUN (Fcurrent_window_configuration, 1); 857EXFUN (Fcurrent_window_configuration, 1);
859extern int compare_window_configurations (Lisp_Object, Lisp_Object, int); 858extern int compare_window_configurations (Lisp_Object, Lisp_Object, int);
diff --git a/test/ChangeLog b/test/ChangeLog
index b247b88bc94..dc9b87adfac 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,7 @@
12011-03-10 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/lexbind-tests.el: New file.
4
12011-03-05 Glenn Morris <rgm@gnu.org> 52011-03-05 Glenn Morris <rgm@gnu.org>
2 6
3 * eshell.el: Move here from lisp/eshell/esh-test.el. 7 * eshell.el: Move here from lisp/eshell/esh-test.el.
diff --git a/test/automated/lexbind-tests.el b/test/automated/lexbind-tests.el
new file mode 100644
index 00000000000..95b8bbe8858
--- /dev/null
+++ b/test/automated/lexbind-tests.el
@@ -0,0 +1,75 @@
1;;; lexbind-tests.el --- Testing the lexbind byte-compiler
2
3;; Copyright (C) 2011 Free Software Foundation, Inc.
4
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6;; Keywords:
7
8;; This program is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20
21;;; Commentary:
22
23;;
24
25;;; Code:
26
27(require 'ert)
28
29(defconst lexbind-tests
30 `(
31 (let ((f #'car))
32 (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
33 (funcall f '(1 . 2))))
34 )
35 "List of expression for test.
36Each element will be executed by interpreter and with
37bytecompiled code, and their results compared.")
38
39
40
41(defun lexbind-check-1 (pat)
42 "Return non-nil if PAT is the same whether directly evalled or compiled."
43 (let ((warning-minimum-log-level :emergency)
44 (byte-compile-warnings nil)
45 (v0 (condition-case nil
46 (eval pat t)
47 (error nil)))
48 (v1 (condition-case nil
49 (funcall (let ((lexical-binding t))
50 (byte-compile `(lambda nil ,pat))))
51 (error nil))))
52 (equal v0 v1)))
53
54(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1)
55
56(defun lexbind-explain-1 (pat)
57 (let ((v0 (condition-case nil
58 (eval pat t)
59 (error nil)))
60 (v1 (condition-case nil
61 (funcall (let ((lexical-binding t))
62 (byte-compile (list 'lambda nil pat))))
63 (error nil))))
64 (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
65 pat v0 v1)))
66
67(ert-deftest lexbind-tests ()
68 "Test the Emacs byte compiler lexbind handling."
69 (dolist (pat lexbind-tests)
70 (should (lexbind-check-1 pat))))
71
72
73
74(provide 'lexbind-tests)
75;;; lexbind-tests.el ends here