mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-29 19:48:19 +00:00
Code Issues Releases Activity

Merge from lexical-binding branch.

Browse Source 
* doc/lispref/eval.texi (Eval): Discourage the use of `eval'.
Document its new `lexical' argument.

* doc/lispref/variables.texi (Defining Variables): Mention the new meaning of `defvar'.
(Lexical Binding): New sub-section.

* lisp/Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS):
New variables.
(compile-onefile, .el.elc, compile-calc, recompile): Use them.
(COMPILE_FIRST): Add macroexp and cconv.
* lisp/makefile.w32-in: Mirror changes in Makefile.in.

* lisp/vc/cvs-status.el:
* lisp/vc/diff-mode.el:
* lisp/vc/log-edit.el:
* lisp/vc/log-view.el:
* lisp/vc/smerge-mode.el:
* lisp/textmodes/bibtex-style.el:
* textmodes/css.el:
* lisp/startup.el:
* lisp/uniquify.el:
* lisp/minibuffer.el: 
* lisp/newcomment.el: 
* lisp/reveal.el: 
* lisp/server.el: 
* lisp/mpc.el: 
* lisp/emacs-lisp/smie.el: 
* lisp/doc-view.el: 
* lisp/dired.el: 
* lisp/abbrev.el: Use lexical binding.

* lisp/custom.el (custom-initialize-default, custom-declare-variable):
Use `defvar'.

* lisp/files.el (lexical-binding): Declare safe.

* lisp/help-fns.el (help-split-fundoc): Return nil if there's nothing else
than the arglist.
(help-add-fundoc-usage): Don't add `Not documented'.
(help-function-arglist): Handle closures, subroutines, and new
byte-code-functions.
(help-make-usage): Remove leading underscores.
(describe-function-1): Handle closures.
(describe-variable): Use special-variable-p for completion.

* lisp/simple.el (with-wrapper-hook, apply-partially): Move to subr.el.

* lisp/subr.el (apply-partially): Use new closures rather than CL.
(--dolist-tail--, --dotimes-limit--): Don't declare dynamic.
(dolist, dotimes): Use slightly different expansion for lexical code.
(functionp): Move to C.
(letrec): New macro.
(with-wrapper-hook): Use it and apply-partially instead of CL.
(eval-after-load): Preserve lexical-binding.
(save-window-excursion, with-output-to-temp-buffer): Turn them
into macros.

* lisp/emacs-lisp/advice.el (ad-arglist): Use help-function-arglist.

* lisp/emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros.

* lisp/emacs-lisp/byte-opt.el: Use lexical binding.
(byte-inline-lapcode): Remove (to bytecomp).
(byte-compile-inline-expand): Pay attention to inlining to/from
lexically bound code.
(byte-compile-unfold-lambda): Don't handle byte-code-functions
any more.
(byte-optimize-form-code-walker): Don't handle save-window-excursion
any more and don't call compiler-macros.
(byte-compile-splice-in-already-compiled-code): Remove.
(byte-code): Don't inline any more.
(disassemble-offset): Receive `bytes' as argument rather than via
dynamic scoping.
(byte-compile-tag-number): Declare before first use.
(byte-decompile-bytecode-1): Handle new byte-codes, don't change
`return' even if make-spliceable.
(byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove
obsolete interactive-p.
(byte-optimize-lapcode): Optimize new lap-codes.
Don't trip up on new form of `byte-constant' lap code.

* lisp/emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile'
handler any more.

* lisp/emacs-lisp/bytecomp.el: Use lexical binding instead of
a "bytecomp-" prefix.  Macroexpand everything as a separate phase.
(byte-compile-initial-macro-environment):
Handle declare-function here.
(byte-compile--lexical-environment): New var.
(byte-stack-ref, byte-stack-set, byte-discardN)
(byte-discardN-preserve-tos): New lap codes.
(byte-interactive-p): Don't use any more.
(byte-compile-push-bytecodes, byte-compile-push-bytecode-const2):
New macros.
(byte-compile-lapcode): Use them and handle new lap codes.
(byte-compile-obsolete): Remove.
(byte-compile-arglist-signature): Handle new byte-code arg"lists".
(byte-compile-arglist-warn): Check late def of inlinable funs.
(byte-compile-cl-warn): Don't silence warnings for compiler-macros
since they should have been expanded by now.
(byte-compile--outbuffer): Rename from bytecomp-outbuffer.
(byte-compile-from-buffer): Remove unused second arg.
(byte-compile-preprocess): New function.
(byte-compile-toplevel-file-form): New function to distinguish
file-form calls from outside from file-form calls from hunk-handlers.
(byte-compile-file-form): Simplify.
(byte-compile-file-form-defsubst): Remove.
(byte-compile-file-form-defmumble): Simplify now that
byte-compile-lambda always returns a byte-code-function.
(byte-compile): Preprocess.
(byte-compile-byte-code-maker, byte-compile-byte-code-unmake):
Remove, not used any more.
(byte-compile-arglist-vars, byte-compile-make-lambda-lexenv)
(byte-compile-make-args-desc): New funs.
(byte-compile-lambda): Handle lexical functions.  Always return
a byte-code-function.
(byte-compile-reserved-constants): New var, to make up room for
closed-over variables.
(byte-compile-constants-vector): Obey it.
(byte-compile-top-level): New args `lexenv' and `reserved-csts'.
(byte-compile-macroexpand-declare-function): New function.
(byte-compile-form): Call byte-compile-unfold-bcf to inline immediate
byte-code-functions.
(byte-compile-form): Check obsolescence here.
(byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions.
(byte-compile-variable-ref): Remove.
(byte-compile-dynamic-variable-op): New fun.
(byte-compile-dynamic-variable-bind, byte-compile-variable-ref)
(byte-compile-variable-set): New funs.
(byte-compile-discard): Add 2 args.
(byte-compile-stack-ref, byte-compile-stack-set)
(byte-compile-make-closure, byte-compile-get-closed-var): New funs.
(byte-compile-funarg, byte-compile-funarg-2): Remove, handled in
macroexpand-all instead.
(byte-compile-quote-form): Remove.
(byte-compile-push-binding-init, byte-compile-not-lexical-var-p)
(byte-compile-bind, byte-compile-unbind): New funs.
(byte-compile-let): Handle let* and lexical binding.
(byte-compile-let*): Remove.
(byte-compile-catch, byte-compile-unwind-protect)
(byte-compile-track-mouse, byte-compile-condition-case):
Handle a new :fun-body form, used for lexical scoping.
(byte-compile-save-window-excursion)
(byte-compile-with-output-to-temp-buffer): Remove.
(byte-compile-defun): Simplify.
(byte-compile-stack-adjustment): New fun.
(byte-compile-out): Use it.
(byte-compile-refresh-preloaded): Don't reload byte-compiler files.

* lisp/emacs-lisp/cconv.el: New file.

* lisp/emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL
closures.

* lisp/emacs-lisp/cl-macs.el (cl-byte-compile-block)
(cl-byte-compile-throw): Remove.
(cl-block-wrapper, cl-block-throw): Use compiler-macros instead.

* lisp/emacs-lisp/cl.el (pushnew): Silence warning.

* lisp/emacs-lisp/disass.el (disassemble-internal): Handle new
`closure' objects.
(disassemble-1): Handle new byte codes.

* lisp/emacs-lisp/edebug.el (edebug-eval-defun)
(edebug-eval-top-level-form): Use eval-sexp-add-defvars.
(edebug-toggle): Avoid `eval'.

* lisp/emacs-lisp/eieio-comp.el: Remove.

* lisp/emacs-lisp/eieio.el (byte-compile-file-form-defmethod):
Don't autoload.
(eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather
than the internal `byte-compile-lambda'.
(defmethod): Don't hide code under quotes.
(eieio-defmethod): New `code' argument.

* lisp/emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound.

* lisp/emacs-lisp/lisp-mode.el (eval-last-sexp-1):
Use eval-sexp-add-defvars.
(eval-sexp-add-defvars): New fun.

* lisp/emacs-lisp/macroexp.el: Use lexical binding.
(macroexpand-all-1): Check obsolete macros.  Expand compiler-macros.
Don't convert ' to #' without checking that it's indeed quoting
a lambda.

* lisp/emacs-lisp/pcase.el: Don't use destructuring-bind.
(pcase--memoize): Rename from pcase-memoize.  Change weakness.
(pcase): Add `let' pattern.
Change memoization so it actually works.
(pcase-mutually-exclusive-predicates): Add byte-code-function-p.
(pcase--u1) <guard, pred>: Fix possible shadowing problem.
<let>: New case.

* src/alloc.c (Fmake_symbol): Init new `declared_special' field.

* src/buffer.c (defvar_per_buffer): Set new `declared_special' field.

* src/bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN):
New byte-codes.
(exec_byte_code): New function extracted from Fbyte_code to handle new
calling convention for byte-code-functions.  Add new byte-codes.

* src/callint.c (Fcall_interactively): Preserve lexical-binding mode for
interactive spec.

* src/doc.c (Fdocumentation, store_function_docstring):
* src/data.c (Finteractive_form): Handle closures.

* src/eval.c (Fsetq): Handle lexical vars.
(Fdefun, Fdefmacro, Ffunction): Make closures when needed.
(Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic.
(FletX, Flet): Obey lexical binding.
(Fcommandp): Handle closures.
(Feval): New `lexical' arg.
(eval_sub): New function extracted from Feval.  Use it almost
everywhere where Feval was used.  Look up vars in lexical env.
Handle closures.
(Ffunctionp): Move from subr.el.
(Ffuncall): Handle closures.
(apply_lambda): Remove `eval_flags'.
(funcall_lambda): Handle closures and new byte-code-functions.
(Fspecial_variable_p): New function.
(syms_of_eval): Initialize the Vinternal_interpreter_environment var,
but without exporting it to Lisp.

* src/fns.c (concat, mapcar1): Accept byte-code-functions.

* src/image.c (parse_image_spec): Use Ffunctionp.

* src/keyboard.c (eval_dyn): New fun.
(menu_item_eval_property): Use it.

* src/lisp.h (struct Lisp_Symbol): New field `declared_special'.

* src/lread.c (lisp_file_lexically_bound_p): New function.
(Fload): Bind Qlexical_binding.
(readevalloop): Remove `evalfun' arg.
Bind Qinternal_interpreter_environment.
(Feval_buffer): Bind Qlexical_binding.
(defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard):
Mark as dynamic.
(syms_of_lread): Declare `lexical-binding'.

* src/window.c (Ftemp_output_buffer_show): New fun.
(Fsave_window_excursion):
* src/print.c (Fwith_output_to_temp_buffer): Move to subr.el.
This commit is contained in:
Stefan Monnier 2011-04-01 13:19:52 -04:00
commit 034086489c
72 changed files with 4629 additions and 2482 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.dir-locals.el
View File

@ -1,6 +1,6 @@
((nil . ((tab-width . 8)
(sentence-end-double-space . t)
(fill-column . 70)))
(fill-column . 79)))
(c-mode . ((c-file-style . "GNU")))
;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work.
;; See admin/notes/bugtracker.

10
doc/lispref/ChangeLog
View File

@ -1,6 +1,14 @@
2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
* variables.texi (Defining Variables): Mention the new meaning of `defvar'.
(Lexical Binding): New sub-section.
* eval.texi (Eval): Discourage the use of `eval'.
Document its new `lexical' argument.
2011-03-28 Stefan Monnier <monnier@iro.umontreal.ca>
* commands.texi (Command Overview): post-command-hook is not reset to
* commands.texi (Command Overview): `post-command-hook' is not reset to
nil any more.
2011-03-19 Stefan Monnier <monnier@iro.umontreal.ca>

10
doc/lispref/eval.texi
View File

@ -585,6 +585,11 @@ occurrence in a program being run. On rare occasions, you may need to
write code that evaluates a form that is computed at run time, such as
after reading a form from text being edited or getting one from a
property list. On these occasions, use the @code{eval} function.
Often @code{eval} is not needed and something else should be used instead.
For example, to get the value of a variable, while @code{eval} works,
@code{symbol-value} is preferable; or rather than store expressions
in a property list that then need to go through @code{eval}, it is better to
store functions instead that are then passed to @code{funcall}.
The functions and variables described in this section evaluate forms,
specify 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
functions provides the ability to pass information to them as
arguments.
@defun eval form
@defun eval form &optional lexical
This is the basic function evaluating an expression. It evaluates
@var{form} in the current environment and returns the result. How the
evaluation proceeds depends on the type of the object (@pxref{Forms}).
@var{lexical} if non-nil means to evaluate @var{form} using lexical scoping
rules (@pxref{Lexical Binding}) instead of the default dynamic scoping used
historically in Emacs Lisp.
Since @code{eval} is a function, the argument expression that appears
in a call to @code{eval} is evaluated twice: once as preparation before

149
doc/lispref/variables.texi
View File

@ -25,22 +25,22 @@ textual Lisp program is written using the read syntax for the symbol
representing the variable.
@menu
* Global Variables:: Variable values that exist permanently, everywhere.
* Constant Variables:: Certain "variables" have values that never change.
* Local Variables:: Variable values that exist only temporarily.
* Void Variables:: Symbols that lack values.
* Defining Variables:: A definition says a symbol is used as a variable.
* Tips for Defining:: Things you should think about when you
* Global Variables:: Variable values that exist permanently, everywhere.
* Constant Variables:: Certain "variables" have values that never change.
* Local Variables:: Variable values that exist only temporarily.
* Void Variables:: Symbols that lack values.
* Defining Variables:: A definition says a symbol is used as a variable.
* Tips for Defining:: Things you should think about when you
define a variable.
* Accessing Variables:: Examining values of variables whose names
* Accessing Variables:: Examining values of variables whose names
are known only at run time.
* Setting Variables:: Storing new values in variables.
* Variable Scoping:: How Lisp chooses among local and global values.
* Buffer-Local Variables:: Variable values in effect only in one buffer.
* File Local Variables:: Handling local variable lists in files.
* Directory Local Variables:: Local variables common to all files in a directory.
* Frame-Local Variables:: Frame-local bindings for variables.
* Variable Aliases:: Variables that are aliases for other variables.
* Setting Variables:: Storing new values in variables.
* Variable Scoping:: How Lisp chooses among local and global values.
* Buffer-Local Variables:: Variable values in effect only in one buffer.
* File Local Variables:: Handling local variable lists in files.
* Directory Local Variables:: Local variables common to all files in a directory.
* Frame-Local Variables:: Frame-local bindings for variables.
* Variable Aliases:: Variables that are aliases for other variables.
* Variables with Restricted Values:: Non-constant variables whose value can
@emph{not} be an arbitrary Lisp object.
@end menu
@ -437,14 +437,18 @@ this reason, user options must be defined with @code{defvar}.
This special form defines @var{symbol} as a variable and can also
initialize and document it. The definition informs a person reading
your code that @var{symbol} is used as a variable that might be set or
changed. Note that @var{symbol} is not evaluated; the symbol to be
defined must appear explicitly in the @code{defvar}.
changed. It also declares this variable as @dfn{special}, meaning that it
should always use dynamic scoping rules. Note that @var{symbol} is not
evaluated; the symbol to be defined must appear explicitly in the
@code{defvar}.
If @var{symbol} is void and @var{value} is specified, @code{defvar}
evaluates it and sets @var{symbol} to the result. But if @var{symbol}
already has a value (i.e., it is not void), @var{value} is not even
evaluated, and @var{symbol}'s value remains unchanged. If @var{value}
is omitted, the value of @var{symbol} is not changed in any case.
evaluated, and @var{symbol}'s value remains unchanged.
If @var{value} is omitted, the value of @var{symbol} is not changed in any
case; instead, the only effect of @code{defvar} is to declare locally that this
variable exists elsewhere and should hence always use dynamic scoping rules.
If @var{symbol} has a buffer-local binding in the current buffer,
@code{defvar} operates on the default value, which is buffer-independent,
@ -881,7 +885,7 @@ the others.
@cindex extent
@cindex dynamic scoping
@cindex lexical scoping
Local bindings in Emacs Lisp have @dfn{indefinite scope} and
By default, local bindings in Emacs Lisp have @dfn{indefinite scope} and
@dfn{dynamic extent}. @dfn{Scope} refers to @emph{where} textually in
the source code the binding can be accessed. ``Indefinite scope'' means
that 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.
@dfn{dynamic scoping}. By contrast, most programming languages use
@dfn{lexical scoping}, in which references to a local variable must be
located textually within the function or block that binds the variable.
Emacs can also support lexical scoping, upon request (@pxref{Lexical
Binding}).
@cindex CL note---special variables
@quotation
@ -901,11 +907,12 @@ dynamically scoped, like all variables in Emacs Lisp.
@end quotation
@menu
* Scope:: Scope means where in the program a value is visible.
* Scope:: Scope means where in the program a value is visible.
Comparison with other languages.
* Extent:: Extent means how long in time a value exists.
* Impl of Scope:: Two ways to implement dynamic scoping.
* Using Scoping:: How to use dynamic scoping carefully and avoid problems.
* Extent:: Extent means how long in time a value exists.
* Impl of Scope:: Two ways to implement dynamic scoping.
* Using Scoping:: How to use dynamic scoping carefully and avoid problems.
* Lexical Binding:: Use of lexical scoping.
@end menu
@node Scope
@ -969,12 +976,12 @@ Here, when @code{foo} is called by @code{binder}, it binds @code{x}.
by @code{foo} instead of the one bound by @code{binder}.
@end itemize
Emacs Lisp uses dynamic scoping because simple implementations of
Emacs Lisp used dynamic scoping by default because simple implementations of
lexical scoping are slow. In addition, every Lisp system needs to offer
dynamic scoping at least as an option; if lexical scoping is the norm,
there must be a way to specify dynamic scoping instead for a particular
variable. It might not be a bad thing for Emacs to offer both, but
implementing it with dynamic scoping only was much easier.
dynamic scoping at least as an option; if lexical scoping is the norm, there
must be a way to specify dynamic scoping instead for a particular variable.
Nowadays, Emacs offers both, but the default is still to use exclusively
dynamic scoping.
@node Extent
@subsection Extent
@ -1088,6 +1095,86 @@ for inter-function usage. It also avoids a warning from the byte
compiler. Choose the variable's name to avoid name conflicts---don't
use short names like @code{x}.
@node Lexical Binding
@subsection Use of Lexical Scoping
Emacs Lisp can be evaluated in two different modes: in dynamic binding mode or
lexical binding mode. In dynamic binding mode, all local variables use dynamic
scoping, whereas in lexical binding mode variables that have been declared
@dfn{special} (i.e., declared with @code{defvar} or @code{defconst}) use
dynamic scoping and all others use lexical scoping.
@defvar lexical-binding
When non-nil, evaluation of Lisp code uses lexical scoping for non-special
local variables instead of dynamic scoping. If nil, dynamic scoping is used
for all local variables. This variable is typically set for a whole Elisp file
via file local variables (@pxref{File Local Variables}).
@end defvar
@defun special-variable-p SYMBOL
Return whether SYMBOL has been declared as a special variable, via
@code{defvar} or @code{defconst}.
@end defun
The use of a special variable as a formal argument in a function is generally
discouraged and its behavior in lexical binding mode is unspecified (it may use
lexical scoping sometimes and dynamic scoping other times).
Functions like @code{symbol-value}, @code{boundp}, or @code{set} only know
about dynamically scoped variables, so you cannot get the value of a lexical
variable via @code{symbol-value} and neither can you change it via @code{set}.
Another particularity is that code in the body of a @code{defun} or
@code{defmacro} cannot refer to surrounding lexical variables.
Evaluation of a @code{lambda} expression in lexical binding mode will not just
return that lambda expression unchanged, as in the dynamic binding case, but
will instead construct a new object that remembers the current lexical
environment in which that lambda expression was defined, so that the function
body can later be evaluated in the proper context. Those objects are called
@dfn{closures}. They are also functions, in the sense that they are accepted
by @code{funcall}, and they are represented by a cons cell whose @code{car} is
the symbol @code{closure}.
@menu
* Converting to Lexical Binding:: How to start using lexical scoping
@end menu
@node Converting to Lexical Binding
@subsubsection Converting a package to use lexical scoping
Lexical scoping, as currently implemented, does not bring many significant
benefits, unless you are a seasoned functional programmer addicted to
higher-order functions. But its importance will increase in the future:
lexical scoping opens up a lot more opportunities for optimization, so
lexically scoped code is likely to run faster in future Emacs versions, and it
is much more friendly to concurrency, which we want to add in the near future.
Converting a package to lexical binding is usually pretty easy and should not
break backward compatibility: just add a file-local variable setting
@code{lexical-binding} to @code{t} and add declarations of the form
@code{(defvar @var{VAR})} for every variable which still needs to use
dynamic scoping.
To find which variables need this declaration, the simplest solution is to
check the byte-compiler's warnings. The byte-compiler will usually find those
variables either because they are used outside of a let-binding (leading to
warnings about reference or assignment to ``free variable @var{VAR}'') or
because they are let-bound but not used within the let-binding (leading to
warnings about ``unused lexical variable @var{VAR}'').
In cases where a dynamically scoped variable was bound as a function argument,
you will also need to move this binding to a @code{let}. These cases are also
flagged by the byte-compiler.
To silence byte-compiler warnings about unused variables, just use a variable
name that start with an underscore, which the byte-compiler interpret as an
indication that this is a variable known not to be used.
In most cases, the resulting code will then work with either setting of
@code{lexical-binding}, so it can still be used with older Emacsen (which will
simply ignore the @code{lexical-binding} variable setting).
@node Buffer-Local Variables
@section Buffer-Local Variables
@cindex variable, buffer-local
@ -1103,9 +1190,9 @@ local to each terminal, or to each frame. @xref{Multiple Terminals},
and @xref{Frame-Local Variables}.)
@menu
* Intro to Buffer-Local:: Introduction and concepts.
* Creating Buffer-Local:: Creating and destroying buffer-local bindings.
* Default Value:: The default value is seen in buffers
* Intro to Buffer-Local:: Introduction and concepts.
* Creating Buffer-Local:: Creating and destroying buffer-local bindings.
* Default Value:: The default value is seen in buffers
that don't have their own buffer-local values.
@end menu

16
etc/NEWS
View File

@ -773,6 +773,22 @@ sc.el, x-menu.el, rnews.el, rnewspost.el
* Lisp changes in Emacs 24.1
** Code can now use lexical scoping by default instead of dynamic scoping.
The `lexical-binding' variable lets code use lexical scoping for local
variables. It is typically set via file-local variables, in which case it
applies to all the code in that file.
*** `eval' takes a new optional argument `lexical' to choose the new lexical
binding instead of the old dynamic binding mode.
*** Lexically scoped interpreted functions are represented with a new form
of function value which looks like (closure ENV ARGS &rest BODY).
*** New macro `letrec' to define recursive local functions.
*** New function `special-variable-p' to check whether a variable is
declared as dynamically bound.
** pre/post-command-hook are not reset to nil upon error.
Instead, the offending function is removed.

198
lisp/ChangeLog
View File

@ -1,3 +1,197 @@
2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
Add lexical binding.
* subr.el (apply-partially): Use new closures rather than CL.
(--dolist-tail--, --dotimes-limit--): Don't declare dynamic.
(dolist, dotimes): Use slightly different expansion for lexical code.
(functionp): Move to C.
(letrec): New macro.
(with-wrapper-hook): Use it and apply-partially instead of CL.
(eval-after-load): Preserve lexical-binding.
(save-window-excursion, with-output-to-temp-buffer): Turn them
into macros.
* simple.el (with-wrapper-hook, apply-partially): Move to subr.el.
* help-fns.el (help-split-fundoc): Return nil if there's nothing else
than the arglist.
(help-add-fundoc-usage): Don't add `Not documented'.
(help-function-arglist): Handle closures, subroutines, and new
byte-code-functions.
(help-make-usage): Remove leading underscores.
(describe-function-1): Handle closures.
(describe-variable): Use special-variable-p for completion.
* files.el (lexical-binding): Declare safe.
* emacs-lisp/pcase.el: Don't use destructuring-bind.
(pcase--memoize): Rename from pcase-memoize. Change weakness.
(pcase): Add `let' pattern.
Change memoization so it actually works.
(pcase-mutually-exclusive-predicates): Add byte-code-function-p.
(pcase--u1) <guard, pred>: Fix possible shadowing problem.
<let>: New case.
* emacs-lisp/macroexp.el: Use lexical binding.
(macroexpand-all-1): Check obsolete macros. Expand compiler-macros.
Don't convert ' to #' without checking that it's indeed quoting
a lambda.
* emacs-lisp/lisp-mode.el (eval-last-sexp-1):
Use eval-sexp-add-defvars.
(eval-sexp-add-defvars): New fun.
* emacs-lisp/float-sup.el (pi): Don't declare as dynamically bound.
* emacs-lisp/eieio.el (byte-compile-file-form-defmethod):
Don't autoload.
(eieio-defgeneric-form-primary-only-one): Use `byte-compile' rather
than the internal `byte-compile-lambda'.
(defmethod): Don't hide code under quotes.
(eieio-defmethod): New `code' argument.
* emacs-lisp/eieio-comp.el: Remove.
* emacs-lisp/edebug.el (edebug-eval-defun)
(edebug-eval-top-level-form): Use eval-sexp-add-defvars.
(edebug-toggle): Avoid `eval'.
* emacs-lisp/disass.el (disassemble-internal): Handle new
`closure' objects.
(disassemble-1): Handle new byte codes.
* emacs-lisp/cl.el (pushnew): Silence warning.
* emacs-lisp/cl-macs.el (cl-byte-compile-block)
(cl-byte-compile-throw): Remove.
(cl-block-wrapper, cl-block-throw): Use compiler-macros instead.
* emacs-lisp/cl-extra.el (cl-macroexpand-all): Properly quote CL
closures.
* emacs-lisp/cconv.el: New file.
* emacs-lisp/bytecomp.el: Use lexical binding instead of
a "bytecomp-" prefix. Macroexpand everything as a separate phase.
(byte-compile-initial-macro-environment):
Handle declare-function here.
(byte-compile--lexical-environment): New var.
(byte-stack-ref, byte-stack-set, byte-discardN)
(byte-discardN-preserve-tos): New lap codes.
(byte-interactive-p): Don't use any more.
(byte-compile-push-bytecodes, byte-compile-push-bytecode-const2):
New macros.
(byte-compile-lapcode): Use them and handle new lap codes.
(byte-compile-obsolete): Remove.
(byte-compile-arglist-signature): Handle new byte-code arg"lists".
(byte-compile-arglist-warn): Check late def of inlinable funs.
(byte-compile-cl-warn): Don't silence warnings for compiler-macros
since they should have been expanded by now.
(byte-compile--outbuffer): Rename from bytecomp-outbuffer.
(byte-compile-from-buffer): Remove unused second arg.
(byte-compile-preprocess): New function.
(byte-compile-toplevel-file-form): New function to distinguish
file-form calls from outside from file-form calls from hunk-handlers.
(byte-compile-file-form): Simplify.
(byte-compile-file-form-defsubst): Remove.
(byte-compile-file-form-defmumble): Simplify now that
byte-compile-lambda always returns a byte-code-function.
(byte-compile): Preprocess.
(byte-compile-byte-code-maker, byte-compile-byte-code-unmake):
Remove, not used any more.
(byte-compile-arglist-vars, byte-compile-make-lambda-lexenv)
(byte-compile-make-args-desc): New funs.
(byte-compile-lambda): Handle lexical functions. Always return
a byte-code-function.
(byte-compile-reserved-constants): New var, to make up room for
closed-over variables.
(byte-compile-constants-vector): Obey it.
(byte-compile-top-level): New args `lexenv' and `reserved-csts'.
(byte-compile-macroexpand-declare-function): New function.
(byte-compile-form): Call byte-compile-unfold-bcf to inline immediate
byte-code-functions.
(byte-compile-form): Check obsolescence here.
(byte-compile-inline-lapcode, byte-compile-unfold-bcf): New functions.
(byte-compile-variable-ref): Remove.
(byte-compile-dynamic-variable-op): New fun.
(byte-compile-dynamic-variable-bind, byte-compile-variable-ref)
(byte-compile-variable-set): New funs.
(byte-compile-discard): Add 2 args.
(byte-compile-stack-ref, byte-compile-stack-set)
(byte-compile-make-closure, byte-compile-get-closed-var): New funs.
(byte-compile-funarg, byte-compile-funarg-2): Remove, handled in
macroexpand-all instead.
(byte-compile-quote-form): Remove.
(byte-compile-push-binding-init, byte-compile-not-lexical-var-p)
(byte-compile-bind, byte-compile-unbind): New funs.
(byte-compile-let): Handle let* and lexical binding.
(byte-compile-let*): Remove.
(byte-compile-catch, byte-compile-unwind-protect)
(byte-compile-track-mouse, byte-compile-condition-case):
Handle a new :fun-body form, used for lexical scoping.
(byte-compile-save-window-excursion)
(byte-compile-with-output-to-temp-buffer): Remove.
(byte-compile-defun): Simplify.
(byte-compile-stack-adjustment): New fun.
(byte-compile-out): Use it.
(byte-compile-refresh-preloaded): Don't reload byte-compiler files.
* emacs-lisp/byte-run.el (make-obsolete): Don't set the `byte-compile'
handler any more.
* emacs-lisp/byte-opt.el: Use lexical binding.
(byte-inline-lapcode): Remove (to bytecomp).
(byte-compile-inline-expand): Pay attention to inlining to/from
lexically bound code.
(byte-compile-unfold-lambda): Don't handle byte-code-functions
any more.
(byte-optimize-form-code-walker): Don't handle save-window-excursion
any more and don't call compiler-macros.
(byte-compile-splice-in-already-compiled-code): Remove.
(byte-code): Don't inline any more.
(disassemble-offset): Receive `bytes' as argument rather than via
dynamic scoping.
(byte-compile-tag-number): Declare before first use.
(byte-decompile-bytecode-1): Handle new byte-codes, don't change
`return' even if make-spliceable.
(byte-compile-side-effect-and-error-free-ops): Add stack-ref, remove
obsolete interactive-p.
(byte-optimize-lapcode): Optimize new lap-codes.
Don't trip up on new form of `byte-constant' lap code.
* emacs-lisp/autoload.el (make-autoload): Don't burp on trivial macros.
* emacs-lisp/advice.el (ad-arglist): Use help-function-arglist.
* custom.el (custom-initialize-default, custom-declare-variable):
Use `defvar'.
* Makefile.in (BIG_STACK_DEPTH, BIG_STACK_OPTS, BYTE_COMPILE_FLAGS):
New variables.
(compile-onefile, .el.elc, compile-calc, recompile): Use them.
(COMPILE_FIRST): Add macroexp and cconv.
* makefile.w32-in: Mirror changes in Makefile.in.
* vc/cvs-status.el:
* vc/diff-mode.el:
* vc/log-edit.el:
* vc/log-view.el:
* vc/smerge-mode.el:
* textmodes/bibtex-style.el:
* textmodes/css.el:
* startup.el:
* uniquify.el:
* minibuffer.el:
* newcomment.el:
* reveal.el:
* server.el:
* mpc.el:
* emacs-lisp/smie.el:
* doc-view.el:
* dired.el:
* abbrev.el: Use lexical binding.
2011-04-01 Eli Zaretskii <eliz@gnu.org>
* info.el (info-display-manual): New function.
@ -73,8 +267,8 @@
2011-03-28 Brian T. Sniffen <bsniffen@akamai.com> (tiny change)
* net/imap.el (imap-shell-open, imap-process-connection-type): Use
imap-process-connection-type for 'shell' streams as well as
* net/imap.el (imap-shell-open, imap-process-connection-type):
Use imap-process-connection-type for 'shell' streams as well as
Kerberos, SSL, other subprocesses.
2011-03-28 Leo Liu <sdl.web@gmail.com>

26
lisp/Makefile.in
View File

@ -70,12 +70,23 @@ AUTOGENEL = loaddefs.el \
cedet/ede/loaddefs.el \
cedet/srecode/loaddefs.el
# Value of max-lisp-eval-depth when compiling initially.
# During bootstrapping the byte-compiler is run interpreted when compiling
# itself, and uses more stack than usual.
#
BIG_STACK_DEPTH = 1200
BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
# Files to compile before others during a bootstrap. This is done to
# speed up the bootstrap process.
COMPILE_FIRST = \
$(lisp)/emacs-lisp/bytecomp.elc \
$(lisp)/emacs-lisp/byte-opt.elc \
$(lisp)/emacs-lisp/macroexp.elc \
$(lisp)/emacs-lisp/cconv.elc \
$(lisp)/emacs-lisp/autoload.elc
# The actual Emacs command run in the targets below.
@ -195,7 +206,9 @@ compile-onefile:
@echo Compiling $(THEFILE)
@# Use byte-compile-refresh-preloaded to try and work around some of
@# the most common bootstrapping problems.
@$(emacs) -l bytecomp -f byte-compile-refresh-preloaded $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(THEFILE)
@$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
-f batch-byte-compile $(THEFILE)
# Files MUST be compiled one by one. If we compile several files in a
# row (i.e., in the same instance of Emacs) we can't make sure that
@ -210,7 +223,11 @@ compile-onefile:
# cannot have prerequisites.
.el.elc:
@echo Compiling $<
@$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $<
@# The BIG_STACK_OPTS are only needed to byte-compile the byte-compiler
@# files, which is normally done in compile-first, but may also be
@# recompiled via this rule.
@$(emacs) $(BYTE_COMPILE_FLAGS) \
-f batch-byte-compile $<
.PHONY: compile-first compile-main compile compile-always
@ -275,7 +292,7 @@ compile-always: doit
compile-calc:
for el in $(lisp)/calc/*.el; do \
echo Compiling $$el; \
$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1;\
done
# Backup compiled Lisp files in elc.tar.gz. If that file already
@ -302,7 +319,8 @@ compile-after-backup: backup-compiled-files compile-always
# since the environment of later files is affected by definitions in
# earlier ones.
recompile: doit $(LOADDEFS) compile-first $(lisp)/progmodes/cc-mode.elc
$(emacs) --eval "(batch-byte-recompile-directory 0)" $(lisp)
$(emacs) $(BYTE_COMPILE_FLAGS) \
--eval "(batch-byte-recompile-directory 0)" $(lisp)
# Update MH-E internal autoloads. These are not to be confused with
# the autoloads for the MH-E entry points, which are already in loaddefs.el.

29
lisp/abbrev.el
View File

@ -1,4 +1,4 @@
;;; abbrev.el --- abbrev mode commands for Emacs
;;; abbrev.el --- abbrev mode commands for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
@ -814,20 +814,19 @@ Returns the abbrev symbol, if expansion took place."
(destructuring-bind (&optional sym name wordstart wordend)
(abbrev--before-point)
(when sym
(let ((value sym))
(unless (or ;; executing-kbd-macro
noninteractive
(window-minibuffer-p (selected-window)))
;; Add an undo boundary, in case we are doing this for
;; a self-inserting command which has avoided making one so far.
(undo-boundary))
;; Now sym is the abbrev symbol.
(setq last-abbrev-text name)
(setq last-abbrev sym)
(setq last-abbrev-location wordstart)
;; If this abbrev has an expansion, delete the abbrev
;; and insert the expansion.
(abbrev-insert sym name wordstart wordend))))))
(unless (or ;; executing-kbd-macro
noninteractive
(window-minibuffer-p (selected-window)))
;; Add an undo boundary, in case we are doing this for
;; a self-inserting command which has avoided making one so far.
(undo-boundary))
;; Now sym is the abbrev symbol.
(setq last-abbrev-text name)
(setq last-abbrev sym)
(setq last-abbrev-location wordstart)
;; If this abbrev has an expansion, delete the abbrev
;; and insert the expansion.
(abbrev-insert sym name wordstart wordend)))))
(defun unexpand-abbrev ()
"Undo the expansion of the last abbrev that expanded.

5
lisp/cedet/ChangeLog
View File

@ -1,3 +1,8 @@
2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
* semantic/wisent/comp.el (wisent-byte-compile-grammar):
Macroexpand before passing to byte-compile-form.
2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
* srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode.

19
lisp/cedet/semantic/wisent/comp.el
View File

@ -3452,15 +3452,13 @@ where:
(if (wisent-automaton-p grammar)
grammar ;; Grammar already compiled just return it
(wisent-with-context compile-grammar
(let* ((gc-cons-threshold 1000000)
automaton)
(let* ((gc-cons-threshold 1000000))
(garbage-collect)
(setq wisent-new-log-flag t)
;; Parse input grammar
(wisent-parse-grammar grammar start-list)
;; Generate the LALR(1) automaton
(setq automaton (wisent-parser-automaton))
automaton))))
(wisent-parser-automaton)))))
;;;; --------------------------
;;;; Byte compile input grammar
@ -3476,8 +3474,19 @@ Automatically called by the Emacs Lisp byte compiler as a
;; automaton internal data structure. Then, because the internal
;; data structure contains an obarray, convert it to a lisp form so
;; it can be byte-compiled.
(byte-compile-form (wisent-automaton-lisp-form (eval form))))
(byte-compile-form
;; FIXME: we macroexpand here since `byte-compile-form' expects
;; macroexpanded code, but that's just a workaround: for lexical-binding
;; the lisp form should have to pass through closure-conversion and
;; `wisent-byte-compile-grammar' is called much too late for that.
;; Why isn't this `wisent-automaton-lisp-form' performed at
;; macroexpansion time? --Stef
(macroexpand-all
(wisent-automaton-lisp-form (eval form)))))
;; FIXME: We shouldn't use a `byte-compile' handler. Maybe using a hash-table
;; instead of an obarray would work around the problem that obarrays
;; aren't printable. Then (put 'wisent-compile-grammar 'side-effect-free t).
(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar)
(defun wisent-automaton-lisp-form (automaton)

39
lisp/custom.el
View File

@ -55,11 +55,9 @@ Otherwise, if symbol has a `saved-value' property, it will evaluate
the car of that and use it as the default binding for symbol.
Otherwise, VALUE will be evaluated and used as the default binding for
symbol."
(unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the standard setting.
(set-default symbol (eval (if (get symbol 'saved-value)
(car (get symbol 'saved-value))
value)))))
(eval `(defvar ,symbol ,(if (get symbol 'saved-value)
(car (get symbol 'saved-value))
value))))
(defun custom-initialize-set (symbol value)
"Initialize SYMBOL based on VALUE.
@ -81,15 +79,15 @@ The value is either the symbol's current value
\(as obtained using the `:get' function), if any,
or the value in the symbol's `saved-value' property if any,
or (last of all) VALUE."
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(cond ((default-boundp symbol)
(funcall (or (get symbol 'custom-get) 'default-value)
symbol))
((get symbol 'saved-value)
(eval (car (get symbol 'saved-value))))
(t
(eval value)))))
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(cond ((default-boundp symbol)
(funcall (or (get symbol 'custom-get) 'default-value)
symbol))
((get symbol 'saved-value)
(eval (car (get symbol 'saved-value))))
(t
(eval value)))))
(defun custom-initialize-changed (symbol value)
"Initialize SYMBOL with VALUE.
@ -142,10 +140,8 @@ set to nil, as the value is no longer rogue."
;; Maybe this option was rogue in an earlier version. It no longer is.
(when (get symbol 'force-value)
(put symbol 'force-value nil))
(when doc
(if (keywordp doc)
(error "Doc string is missing")
(put symbol 'variable-documentation doc)))
(if (keywordp doc)
(error "Doc string is missing"))
(let ((initialize 'custom-initialize-reset)
(requests nil))
(unless (memq :group args)
@ -189,6 +185,13 @@ set to nil, as the value is no longer rogue."
;; Do the actual initialization.
(unless custom-dont-initialize
(funcall initialize symbol default)))
;; Use defvar to set the docstring as well as the special-variable-p flag.
;; FIXME: We should reproduce more of `defvar's behavior, such as the warning
;; when the var is currently let-bound.
(if (not (default-boundp symbol))
;; Don't use defvar to avoid setting a default-value when undesired.
(when doc (put symbol 'variable-documentation doc))
(eval `(defvar ,symbol nil ,@(when doc (list doc)))))
(push symbol current-load-list)
(run-hooks 'custom-define-hook)
symbol)

32
lisp/dired.el
View File

@ -1,4 +1,4 @@
;;; dired.el --- directory-browsing commands
;;; dired.el --- directory-browsing commands -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1992-1997, 2000-2011
;; Free Software Foundation, Inc.
@ -1181,7 +1181,7 @@ If HDR is non-nil, insert a header line with the directory name."
;; Reverting a dired buffer
(defun dired-revert (&optional arg noconfirm)
(defun dired-revert (&optional _arg _noconfirm)
"Reread the dired buffer.
Must also be called after `dired-actual-switches' have changed.
Should not fail even on completely garbaged buffers.
@ -2143,7 +2143,7 @@ Optional arg GLOBAL means to replace all matches."
;; dired-get-filename.
(concat (or dir default-directory) file))
(defun dired-make-relative (file &optional dir ignore)
(defun dired-make-relative (file &optional dir _ignore)
"Convert FILE (an absolute file name) to a name relative to DIR.
If this is impossible, return FILE unchanged.
DIR must be a directory name, not a file name."
@ -3233,7 +3233,7 @@ Type \\[help-command] at that time for help."
(interactive "cRemove marks (RET means all): \nP")
(save-excursion
(let* ((count 0)
(inhibit-read-only t) case-fold-search query
(inhibit-read-only t) case-fold-search
(string (format "\n%c" mark))
(help-form "\
Type 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."
(declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist))
(declare-function dnd-get-local-file-uri "dnd" (uri))
(defvar dired-overwrite-confirmed) ;Defined in dired-aux.
(defun dired-dnd-handle-local-file (uri action)
"Copy, move or link a file to the dired directory.
URI 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."
(eval-when-compile (require 'desktop))
(defun dired-desktop-buffer-misc-data (desktop-dirname)
(defun dired-desktop-buffer-misc-data (dirname)
"Auxiliary information to be saved in desktop file."
(cons
;; Value of `dired-directory'.
(if (consp dired-directory)
;; Directory name followed by list of files.
(cons (desktop-file-name (car dired-directory) desktop-dirname)
(cons (desktop-file-name (car dired-directory) dirname)
(cdr dired-directory))
;; Directory name, optionally with shell wildcard.
(desktop-file-name dired-directory desktop-dirname))
(desktop-file-name dired-directory dirname))
;; Subdirectories in `dired-subdir-alist'.
(cdr
(nreverse
(mapcar
(function (lambda (f) (desktop-file-name (car f) desktop-dirname)))
(function (lambda (f) (desktop-file-name (car f) dirname)))
dired-subdir-alist)))))
(defun dired-restore-desktop-buffer (desktop-buffer-file-name
desktop-buffer-name
desktop-buffer-misc)
(defun dired-restore-desktop-buffer (_file-name
_buffer-name
misc-data)
"Restore a dired buffer specified in a desktop file."
;; First element of `desktop-buffer-misc' is the value of `dired-directory'.
;; First element of `misc-data' is the value of `dired-directory'.
;; This value is a directory name, optionally with shell wildcard or
;; a directory name followed by list of files.
(let* ((dired-dir (car desktop-buffer-misc))
(let* ((dired-dir (car misc-data))
(dir (if (consp dired-dir) (car dired-dir) dired-dir)))
(if (file-directory-p (file-name-directory dir))
(progn
(dired dired-dir)
;; The following elements of `desktop-buffer-misc' are the keys
;; The following elements of `misc-data' are the keys
;; from `dired-subdir-alist'.
(mapc 'dired-maybe-insert-subdir (cdr desktop-buffer-misc))
(mapc 'dired-maybe-insert-subdir (cdr misc-data))
(current-buffer))
(message "Desktop: Directory %s no longer exists." dir)
(when desktop-missing-file-warning (sit-for 1))

43
lisp/doc-view.el
View File

@ -1,4 +1,5 @@
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;;
@ -155,7 +156,7 @@
(defcustom doc-view-ghostscript-options
'("-dSAFER" ;; Avoid security problems when rendering files from untrusted
;; sources.
;; sources.
"-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4"
"-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET")
"A list of options to give to ghostscript."
@ -442,9 +443,7 @@ Can be `dvi', `pdf', or `ps'.")
doc-view-current-converter-processes)
;; The PNG file hasn't been generated yet.
(doc-view-pdf->png-1 doc-view-buffer-file-name file page
(lexical-let ((page page)
(win (selected-window))
(file file))
(let ((win (selected-window)))
(lambda ()
(and (eq (current-buffer) (window-buffer win))
;; If we changed page in the mean
@ -453,7 +452,7 @@ Can be `dvi', `pdf', or `ps'.")
;; Make sure we don't infloop.
(file-readable-p file)
(with-selected-window win
(doc-view-goto-page page))))))))
(doc-view-goto-page page))))))))
(overlay-put (doc-view-current-overlay)
'help-echo (doc-view-current-info))))
@ -713,8 +712,8 @@ Should be invoked when the cached images aren't up-to-date."
(if (and doc-view-dvipdf-program
(executable-find doc-view-dvipdf-program))
(doc-view-start-process "dvi->pdf" doc-view-dvipdf-program
(list dvi pdf)
callback)
(list dvi pdf)
callback)
(doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program
(list "-o" pdf dvi)
callback)))
@ -735,7 +734,7 @@ is named like ODF with the extension turned to pdf."
(list (format "-r%d" (round doc-view-resolution))
(concat "-sOutputFile=" png)
pdf-ps))
(lexical-let ((resolution doc-view-resolution))
(let ((resolution doc-view-resolution))
(lambda ()
;; Only create the resolution file when it's all done, so it also
;; serves as a witness that the conversion is complete.
@ -780,7 +779,7 @@ Start by converting PAGES, and then the rest."
;; (almost) consecutive, but since in 99% of the cases, there'll be only
;; a single page anyway, and of the remaining 1%, few cases will have
;; consecutive pages, it's not worth the trouble.
(lexical-let ((pdf pdf) (png png) (rest (cdr pages)))
(let ((rest (cdr pages)))
(doc-view-pdf->png-1
pdf (format png (car pages)) (car pages)
(lambda ()
@ -793,8 +792,8 @@ Start by converting PAGES, and then the rest."
;; not sufficient.
(dolist (win (get-buffer-window-list (current-buffer) nil 'visible))
(with-selected-window win
(when (stringp (get-char-property (point-min) 'display))
(doc-view-goto-page (doc-view-current-page)))))
(when (stringp (get-char-property (point-min) 'display))
(doc-view-goto-page (doc-view-current-page)))))
;; Convert the rest of the pages.
(doc-view-pdf/ps->png pdf png)))))))
@ -816,10 +815,8 @@ Start by converting PAGES, and then the rest."
(ps
;; Doc is a PS, so convert it to PDF (which will be converted to
;; TXT thereafter).
(lexical-let ((pdf (expand-file-name "doc.pdf"
(doc-view-current-cache-dir)))
(txt txt)
(callback callback))
(let ((pdf (expand-file-name "doc.pdf"
(doc-view-current-cache-dir))))
(doc-view-ps->pdf doc-view-buffer-file-name pdf
(lambda () (doc-view-pdf->txt pdf txt callback)))))
(dvi
@ -873,9 +870,7 @@ Those files are saved in the directory given by the function
(dvi
;; DVI files have to be converted to PDF before Ghostscript can process
;; it.
(lexical-let
((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))
(png-file png-file))
(let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)))
(doc-view-dvi->pdf doc-view-buffer-file-name pdf
(lambda () (doc-view-pdf/ps->png pdf png-file)))))
(odf
@ -1026,8 +1021,8 @@ have the page we want to view."
(and (not (member pagefile prev-pages))
(member pagefile doc-view-current-files)))
(with-selected-window win
(assert (eq (current-buffer) buffer))
(doc-view-goto-page page))))))))
(assert (eq (current-buffer) buffer))
(doc-view-goto-page page))))))))
(defun doc-view-buffer-message ()
;; 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."
(when (not (eq major-mode 'doc-view-mode))
(doc-view-toggle-display))
(with-selected-window
(or (get-buffer-window (current-buffer) 0)
(selected-window))
(doc-view-goto-page page)))))
(or (get-buffer-window (current-buffer) 0)
(selected-window))
(doc-view-goto-page page)))))
(provide 'doc-view)

16
lisp/emacs-lisp/advice.el
View File

@ -2535,17 +2535,11 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
"Return the argument list of DEFINITION.
If DEFINITION could be from a subr then its NAME should be
supplied to make subr arglist lookup more efficient."
(cond ((ad-compiled-p definition)
(aref (ad-compiled-code definition) 0))
((consp definition)
(car (cdr (ad-lambda-expression definition))))
((ad-subr-p definition)
(if name
(ad-subr-arglist name)
;; otherwise get it from its printed representation:
(setq name (format "%s" definition))
(string-match "^#<subr \\([^>]+\\)>$" name)
(ad-subr-arglist (intern (match-string 1 name)))))))
(require 'help-fns)
(cond
((or (ad-macro-p definition) (ad-advice-p definition))
(help-function-arglist (cdr definition)))
(t (help-function-arglist definition))))
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish
;; a defined empty arglist `(nil)' from an undefined arglist:

5
lisp/emacs-lisp/autoload.el
View File

@ -137,7 +137,7 @@ or macro definition or a defcustom)."
;; Special case to autoload some of the macro's declarations.
(let ((decls (nth (if (stringp (nth 3 form)) 4 3) form))
(exps '()))
(when (eq (car decls) 'declare)
(when (eq (car-safe decls) 'declare)
;; FIXME: We'd like to reuse macro-declaration-function,
;; but we can't since it doesn't return anything.
(dolist (decl decls)
@ -471,7 +471,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(marker-buffer output-start)))
(autoload-print-form autoload)))
(error
(message "Error in %s: %S" file err)))
(message "Autoload cookie error in %s:%s %S"
file (count-lines (point-min) (point)) err)))
;; Copy the rest of the line to the output.
(princ (buffer-substring

439
lisp/emacs-lisp/byte-opt.el
View File

@ -1,4 +1,4 @@
;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
;; Copyright (C) 1991, 1994, 2000-2011 Free Software Foundation, Inc.
@ -186,8 +186,10 @@
(eval-when-compile (require 'cl))
(defun byte-compile-log-lap-1 (format &rest args)
(if (aref byte-code-vector 0)
(error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
;; Newer byte codes for stack-ref make the slot 0 non-nil again.
;; But the "old disassembler" is *really* ancient by now.
;; (if (aref byte-code-vector 0)
;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
(byte-compile-log-1
(apply 'format format
(let (c a)
@ -242,58 +244,72 @@
sexp)))
(cdr form))))
;; Splice the given lap code into the current instruction stream.
;; If it has any labels in it, you're responsible for making sure there
;; are no collisions, and that byte-compile-tag-number is reasonable
;; after this is spliced in. The provided list is destroyed.
(defun byte-inline-lapcode (lap)
(setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
(fn (or (cdr (assq name byte-compile-function-environment))
(and (fboundp name) (symbol-function name)))))
(if (null fn)
(progn
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
form)
;; else
(when (and (consp fn) (eq (car fn) 'autoload))
(load (nth 1 fn))
(setq fn (or (and (fboundp name) (symbol-function name))
(cdr (assq name byte-compile-function-environment)))))
(if (and (consp fn) (eq (car fn) 'autoload))
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
(if (and (symbolp fn) (not (eq fn t)))
(byte-compile-inline-expand (cons fn (cdr form)))
(if (byte-code-function-p fn)
(let (string)
(fetch-bytecode fn)
(setq string (aref fn 1))
;; Isn't it an error for `string' not to be unibyte?? --stef
(if (fboundp 'string-as-unibyte)
(setq string (string-as-unibyte string)))
;; `byte-compile-splice-in-already-compiled-code'
;; takes care of inlining the body.
(cons `(lambda ,(aref fn 0)
(byte-code ,string ,(aref fn 2) ,(aref fn 3)))
(cdr form)))
(if (eq (car-safe fn) 'lambda)
(cons fn (cdr form))
;; Give up on inlining.
form))))))
(localfn (cdr (assq name byte-compile-function-environment)))
(fn (or localfn (and (fboundp name) (symbol-function name)))))
(when (and (consp fn) (eq (car fn) 'autoload))
(load (nth 1 fn))
(setq fn (or (and (fboundp name) (symbol-function name))
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
(`nil
(byte-compile-warn "attempt to inline `%s' before it was defined"
name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
(byte-compile-inline-expand (cons fn (cdr form))))
((pred byte-code-function-p)
;; (message "Inlining byte-code for %S!" name)
;; The byte-code will be really inlined in byte-compile-unfold-bcf.
`(,fn ,@(cdr form)))
((or (and `(lambda ,args . ,body) (let env nil))
`(closure ,env ,args . ,body))
(if (not (or (eq fn localfn) ;From the same file => same mode.
(eq (not lexical-binding) (not env)))) ;Same mode.
;; While byte-compile-unfold-bcf can inline dynbind byte-code into
;; letbind byte-code (or any other combination for that matter), we
;; can only inline dynbind source into dynbind source or letbind
;; source into letbind source.
;; FIXME: we could of course byte-compile the inlined function
;; first, and then inline its byte-code.
form
(let ((renv ()))
;; Turn the function's closed vars (if any) into local let bindings.
(dolist (binding env)
(cond
((consp binding)
;; We check shadowing by the args, so that the `let' can be
;; moved within the lambda, which can then be unfolded.
;; FIXME: Some of those bindings might be unused in `body'.
(unless (memq (car binding) args) ;Shadowed.
(push `(,(car binding) ',(cdr binding)) renv)))
((eq binding t))
(t (push `(defvar ,binding) body))))
(let ((newfn (byte-compile-preprocess
(if (null renv)
`(lambda ,args ,@body)
`(lambda ,args (let ,(nreverse renv) ,@body))))))
(if (eq (car-safe newfn) 'function)
(byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
(byte-compile-log-warning
(format "Inlining closure %S failed" name))
form)))))
(t ;; Give up on inlining.
form))))
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
;; In lexical-binding mode, let and functions don't bind vars in the same way
;; (let obey special-variable-p, but functions don't). But luckily, this
;; doesn't matter here, because function's behavior is underspecified so it
;; can safely be turned into a `let', even though the reverse is not true.
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(values (cdr form)))
(if (byte-code-function-p lambda)
(setq lambda (list 'lambda (aref lambda 0)
(list 'byte-code (aref lambda 1)
(aref lambda 2) (aref lambda 3)))))
(let ((arglist (nth 1 lambda))
(body (cdr (cdr lambda)))
optionalp restp
@ -302,6 +318,7 @@
(setq body (cdr body)))
(if (and (consp (car body)) (eq 'interactive (car (car body))))
(setq body (cdr body)))
;; FIXME: The checks below do not belong in an optimization phase.
(while arglist
(cond ((eq (car arglist) '&optional)
;; ok, I'll let this slide because funcall_lambda() does...
@ -379,8 +396,7 @@
(and (nth 1 form)
(not for-effect)
form))
((or (byte-code-function-p fn)
(eq 'lambda (car-safe fn)))
((eq 'lambda (car-safe fn))
(let ((newform (byte-compile-unfold-lambda form)))
(if (eq newform form)
;; Some error occurred, avoid infinite recursion
@ -455,8 +471,8 @@
(byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (nthcdr 3 form) for-effect)))))
((memq fn '(and or)) ; remember, and/or are control structures.
;; take forms off the back until we can't any more.
((memq fn '(and or)) ; Remember, and/or are control structures.
;; Take forms off the back until we can't any more.
;; In the future it could conceivably be a problem that the
;; subexpressions of these forms are optimized in the reverse
;; order, but it's ok for now.
@ -471,7 +487,8 @@
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
(cons fn (nreverse (mapcar 'byte-optimize-form backwards)))))
(cons fn (nreverse (mapcar 'byte-optimize-form
backwards)))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
@ -479,8 +496,7 @@
(prin1-to-string form))
nil)
((memq fn '(defun defmacro function
condition-case save-window-excursion))
((memq fn '(defun defmacro function condition-case))
;; These forms are compiled as constants or by breaking out
;; all the subexpressions and compiling them separately.
form)
@ -511,23 +527,11 @@
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
;; If optimization is on, this is the only place that macros are
;; expanded. If optimization is off, then macroexpansion happens
;; in byte-compile-form. Otherwise, the macros are already expanded
;; by the time that is reached.
((not (eq form
(setq form (macroexpand form
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
;; Neeeded as long as we run byte-optimize-form after cconv.
((eq fn 'internal-make-closure) form)
;; Support compiler macros as in cl.el.
((and (fboundp 'compiler-macroexpand)
(symbolp (car-safe form))
(get (car-safe form) 'cl-compiler-macro)
(not (eq form
(with-no-warnings
(setq form (compiler-macroexpand form))))))
(byte-optimize-form form for-effect))
((byte-code-function-p fn)
(cons fn (mapcar #'byte-optimize-form (cdr form))))
((not (symbolp fn))
(byte-compile-warn "`%s' is a malformed function"
@ -605,7 +609,7 @@
(defun byte-optimize-body (forms all-for-effect)
;; optimize the cdr of a progn or implicit progn; all forms is a list of
;; Optimize the cdr of a progn or implicit progn; all forms is a list of
;; forms, all but the last of which are optimized with the assumption that
;; they are being called for effect. the last is for-effect as well if
;; all-for-effect is true. returns a new list of forms.
@ -1085,7 +1089,7 @@
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form)))
form)))
form)))
(defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall.
@ -1291,63 +1295,51 @@
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
nil)
(defun byte-compile-splice-in-already-compiled-code (form)
;; form is (byte-code "..." [...] n)
(if (not (memq byte-optimize '(t lap)))
(byte-compile-normal-call form)
(byte-inline-lapcode
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
(setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
byte-compile-maxdepth))
(setq byte-compile-depth (1+ byte-compile-depth))))
(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
;; Used and set dynamically in byte-decompile-bytecode-1.
(defvar bytedecomp-op)
(defvar bytedecomp-ptr)
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
(defun disassemble-offset ()
(defun disassemble-offset (bytes)
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset
;; Used and set dynamically in byte-decompile-bytecode-1.
(defvar bytedecomp-op)
(defvar bytedecomp-ptr)
(defvar bytedecomp-bytes)
;; Fetch and return the offset for the current opcode.
;; Return nil if this opcode has no offset.
(cond ((< bytedecomp-op byte-nth)
(let ((tem (logand bytedecomp-op 7)))
(setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
;; Offset in next byte.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(aref bytedecomp-bytes bytedecomp-ptr))
(aref bytes bytedecomp-ptr))
((eq tem 7)
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr)
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(t tem)))) ;offset was in opcode
(lsh (aref bytes bytedecomp-ptr) 8))))
(t tem)))) ;Offset was in opcode.
((>= bytedecomp-op byte-constant)
(prog1 (- bytedecomp-op byte-constant) ;offset in opcode
(prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
(setq bytedecomp-op byte-constant)))
((and (>= bytedecomp-op byte-constant2)
(<= bytedecomp-op byte-goto-if-not-nil-else-pop))
((or (and (>= bytedecomp-op byte-constant2)
(<= bytedecomp-op byte-goto-if-not-nil-else-pop))
(= bytedecomp-op byte-stack-set2))
;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr)
(+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(lsh (aref bytes bytedecomp-ptr) 8))))
((and (>= bytedecomp-op byte-listN)
(<= bytedecomp-op byte-insertN))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
(aref bytedecomp-bytes bytedecomp-ptr))))
(<= bytedecomp-op byte-discardN))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
(aref bytes bytedecomp-ptr))))
(defvar byte-compile-tag-number)
;; This de-compiler is used for inline expansion of compiled functions,
;; and by the disassembler.
@ -1369,27 +1361,26 @@
;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
;; In that case, we put a pc value into the list
;; before each insn (or its label).
(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec
&optional make-spliceable)
(let ((length (length bytedecomp-bytes))
(bytedecomp-ptr 0) optr tags bytedecomp-op offset
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
(let ((length (length bytes))
(bytedecomp-ptr 0) optr tags bytedecomp-op offset
lap tmp
endtag)
(while (not (= bytedecomp-ptr length))
(or make-spliceable
(setq lap (cons bytedecomp-ptr lap)))
(setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
(push bytedecomp-ptr lap))
(setq bytedecomp-op (aref bytes bytedecomp-ptr)
optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
;; This uses dynamic-scope magic.
offset (disassemble-offset bytes))
(setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
(cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc
;; It's a pc.
(setq offset
(cdr (or (assq offset tags)
(car (setq tags
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
(let ((new (cons offset (byte-compile-make-tag))))
(push new tags)
new)))))
((cond ((eq bytedecomp-op 'byte-constant2)
(setq bytedecomp-op 'byte-constant) t)
((memq bytedecomp-op byte-constref-ops)))
@ -1399,36 +1390,36 @@
offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
((and make-spliceable
(eq bytedecomp-op 'byte-return))
(if (= bytedecomp-ptr (1- length))
(setq bytedecomp-op nil)
(setq offset (or endtag (setq endtag (byte-compile-make-tag)))
bytedecomp-op 'byte-goto))))
(let ((new (list tmp)))
(push new byte-compile-variables)
new)))))
((eq bytedecomp-op 'byte-stack-set2)
(setq bytedecomp-op 'byte-stack-set))
((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
;; The top bit of the operand for byte-discardN is a flag,
;; saying whether the top-of-stack is preserved. In
;; lapcode, we represent this by using a different opcode
;; (with the flag removed from the operand).
(setq bytedecomp-op 'byte-discardN-preserve-tos)
(setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
(setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
lap))
(push (cons optr (cons bytedecomp-op (or offset 0)))
lap)
(setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
;; this addr is jumped to
;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
(if (null (car (cdr (car lap))))
(setq lap (cdr lap)))
(if endtag
(setq lap (cons (cons nil endtag) lap)))
;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
@ -1463,7 +1454,7 @@
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
byte-current-buffer byte-interactive-p))
byte-current-buffer byte-stack-ref))
(defconst byte-compile-side-effect-free-ops
(nconc
@ -1505,7 +1496,7 @@
;; The variable `byte-boolean-vars' is now primitive and updated
;; automatically by DEFVAR_BOOL.
(defun byte-optimize-lapcode (lap &optional for-effect)
(defun byte-optimize-lapcode (lap &optional _for-effect)
"Simple peephole optimizer. LAP is both modified and returned.
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(let (lap0
@ -1580,9 +1571,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
;; The latter two can enable other optimizations.
;;
;; For lexical variables, we could do the same
;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
;; but this is a very minor gain, since dup is stack-ref-0,
;; i.e. it's only better if X>5, and even then it comes
;; at the cost cost of an extra stack slot. Let's not bother.
((and (eq 'byte-varref (car lap2))
(eq (cdr lap1) (cdr lap2))
(memq (car lap1) '(byte-varset byte-varbind)))
(eq (cdr lap1) (cdr lap2))
(memq (car lap1) '(byte-varset byte-varbind)))
(if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
(not (eq (car lap0) 'byte-constant)))
nil
@ -1611,14 +1607,17 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; dup varset-X discard --> varset-X
;; dup varbind-X discard --> varbind-X
;; dup stack-set-X discard --> stack-set-X-1
;; (the varbind variant can emerge from other optimizations)
;;
((and (eq 'byte-dup (car lap0))
(eq 'byte-discard (car lap2))
(memq (car lap1) '(byte-varset byte-varbind)))
(memq (car lap1) '(byte-varset byte-varbind
byte-stack-set)))
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
(if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
(setq lap (delq lap0 (delq lap2 lap))))
;;
;; 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."
;; it is wrong to do the same thing for the -else-pop variants.
;;
((and (eq 'byte-not (car lap0))
(or (eq 'byte-goto-if-nil (car lap1))
(eq 'byte-goto-if-not-nil (car lap1))))
(memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
(byte-compile-log-lap " not %s\t-->\t%s"
lap1
(cons
@ -1647,8 +1645,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; it is wrong to do the same thing for the -else-pop variants.
;;
((and (or (eq 'byte-goto-if-nil (car lap0))
(eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
((and (memq (car lap0)
'(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
(eq 'byte-goto (car lap1)) ; gotoY
(eq (cdr lap0) lap2)) ; TAG X
(let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
@ -1663,40 +1661,51 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; const goto-if-* --> whatever
;;
((and (eq 'byte-constant (car lap0))
(memq (car lap1) byte-conditional-ops))
(cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
(eq (car lap1) 'byte-goto-if-nil-else-pop))
(car (cdr lap0))
(not (car (cdr lap0))))
(memq (car lap1) byte-conditional-ops)
;; If the `byte-constant's cdr is not a cons cell, it has
;; to be an index into the constant pool); even though
;; it'll be a constant, that constant is not known yet
;; (it's typically a free variable of a closure, so will
;; only be known when the closure will be built at
;; run-time).
(consp (cdr lap0)))
(cond ((if (memq (car lap1) '(byte-goto-if-nil
byte-goto-if-nil-else-pop))
(car (cdr lap0))
(not (car (cdr lap0))))
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(setq rest (cdr rest)
lap (delq lap0 (delq lap1 lap))))
(t
(if (memq (car lap1) byte-goto-always-pop-ops)
(progn
(byte-compile-log-lap " %s %s\t-->\t%s"
lap0 lap1 (cons 'byte-goto (cdr lap1)))
(setq lap (delq lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-goto (cdr lap1))))
(byte-compile-log-lap " %s %s\t-->\t%s"
lap0 lap1
(cons 'byte-goto (cdr lap1)))
(when (memq (car lap1) byte-goto-always-pop-ops)
(setq lap (delq lap0 lap)))
(setcar lap1 'byte-goto)))
(setq keep-going t))
(setq keep-going t))
;;
;; varref-X varref-X --> varref-X dup
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
;; We don't optimize the const-X variations on this here,
;; because that would inhibit some goto optimizations; we
;; optimize the const-X case after all other optimizations.
;;
((and (eq 'byte-varref (car lap0))
((and (memq (car lap0) '(byte-varref byte-stack-ref))
(progn
(setq tmp (cdr rest))
(setq tmp2 0)
(while (eq (car (car tmp)) 'byte-dup)
(setq tmp (cdr tmp)))
(setq tmp2 (1+ tmp2))
(setq tmp (cdr tmp)))
t)
(eq (cdr lap0) (cdr (car tmp)))
(eq 'byte-varref (car (car tmp))))
(eq (if (eq 'byte-stack-ref (car lap0))
(+ tmp2 1 (cdr lap0))
(cdr lap0))
(cdr (car tmp)))
(eq (car lap0) (car (car tmp))))
(if (memq byte-optimize-log '(t byte))
(let ((str ""))
(setq tmp2 (cdr rest))
@ -1856,18 +1865,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap1 (car tmp))))
(setq tmp2 (car tmp))
(cond ((memq (car tmp2)
(if (null (car (cdr lap0)))
'(byte-goto-if-nil byte-goto-if-nil-else-pop)
'(byte-goto-if-not-nil
byte-goto-if-not-nil-else-pop)))
(cond ((when (consp (cdr lap0))
(memq (car tmp2)
(if (null (car (cdr lap0)))
'(byte-goto-if-nil byte-goto-if-nil-else-pop)
'(byte-goto-if-not-nil
byte-goto-if-not-nil-else-pop))))
(byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
lap0 tmp2 lap0 tmp2)
(setcar lap1 (car tmp2))
(setcdr lap1 (cdr tmp2))
;; Let next step fix the (const,goto-if*) sequence.
(setq rest (cons nil rest)))
(t
(setq rest (cons nil rest))
(setq keep-going t))
((or (consp (cdr lap0))
(eq (car tmp2) 'byte-discard))
;; Jump one step further
(byte-compile-log-lap
" %s goto [%s]\t-->\t<deleted> goto <skip>"
@ -1876,13 +1888,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
(setq lap (delq lap0 lap))))
(setq keep-going t))
(setq lap (delq lap0 lap))
(setq keep-going t))))
;;
;; X: varref-Y ... varset-Y goto-X -->
;; X: varref-Y Z: ... dup varset-Y goto-Z
;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
;; (This is so usual for while loops that it is worth handling).
;;
;; Here again, we could do it for stack-ref/stack-set, but
;; that's replacing a stack-ref-Y with a stack-ref-0, which
;; is a very minor improvement (if any), at the cost of
;; more stack use and more byte-code. Let's not do it.
;;
((and (eq (car lap1) 'byte-varset)
(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."
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
;; need to do more than once.
;; need to do more than once.
(setq byte-compile-constants nil
byte-compile-variables nil)
(setq rest lap)
(byte-compile-log-lap " ---- final pass")
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
(if (or (eq (car lap0) 'byte-constant)
(eq (car lap0) 'byte-constant2))
(if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
@ -2008,10 +2025,86 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-unbind
(+ (cdr lap0) (cdr lap1))))
(setq keep-going t)
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
;;
;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
;; stack-set-M [discard/discardN ...] --> discardN
;;
((and (eq (car lap0) 'byte-stack-set)
(memq (car lap1) '(byte-discard byte-discardN))
(progn
;; See if enough discard operations follow to expose or
;; destroy the value stored by the stack-set.
(setq tmp (cdr rest))
(setq tmp2 (1- (cdr lap0)))
(setq tmp3 0)
(while (memq (car (car tmp)) '(byte-discard byte-discardN))
(setq tmp3
(+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
1
(cdr (car tmp)))))
(setq tmp (cdr tmp)))
(>= tmp3 tmp2)))
;; Do the optimization.
(setq lap (delq lap0 lap))
(setcar lap1
(if (= tmp2 tmp3)
;; The value stored is the new TOS, so pop one more
;; value (to get rid of the old value) using the
;; TOS-preserving discard operator.
'byte-discardN-preserve-tos
;; Otherwise, the value stored is lost, so just use a
;; normal discard.
'byte-discardN))
(setcdr lap1 (1+ tmp3))
(setcdr (cdr rest) tmp)
(byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
lap0 lap1))
;;
;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
;; discardN-(X+Y)
;;
((and (memq (car lap0)
'(byte-discard byte-discardN
byte-discardN-preserve-tos))
(memq (car lap1) '(byte-discard byte-discardN)))
(setq lap (delq lap0 lap))
(byte-compile-log-lap
" %s %s\t-->\t(discardN %s)"
lap0 lap1
(+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
(setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
(setcar lap1 'byte-discardN))
;;
;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
;; discardN-preserve-tos-(X+Y)
;;
((and (eq (car lap0) 'byte-discardN-preserve-tos)
(eq (car lap1) 'byte-discardN-preserve-tos))
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap0) (cdr lap1)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
;;
;; discardN-preserve-tos return --> return
;; dup return --> return
;; stack-set-N return --> return ; where N is TOS-1
;;
((and (eq (car lap1) 'byte-return)
(or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
(and (eq (car lap0) 'byte-stack-set)
(= (cdr lap0) 1))))
;; The byte-code interpreter will pop the stack for us, so
;; we can just leave stuff on it.
(setq lap (delq lap0 lap))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)

10
lisp/emacs-lisp/byte-run.el
View File

@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message
If provided, WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
(let ((handler (get obsolete-name 'byte-compile)))
(if (eq 'byte-compile-obsolete handler)
(setq handler (nth 1 (get obsolete-name 'byte-obsolete-info)))
(put obsolete-name 'byte-compile 'byte-compile-obsolete))
(put obsolete-name 'byte-obsolete-info
(list (purecopy current-name) handler (purecopy when))))
(put obsolete-name 'byte-obsolete-info
;; The second entry used to hold the `byte-compile' handler, but
;; is not used any more nowadays.
(list (purecopy current-name) nil (purecopy when)))
obsolete-name)
(set-advertised-calling-convention
;; New code should always provide the `when' argument.

2088
lisp/emacs-lisp/bytecomp.el
View File

File diff suppressed because it is too large Load Diff

713
lisp/emacs-lisp/cconv.el Normal file
View File

@ -0,0 +1,713 @@
;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
;; Maintainer: FSF
;; Keywords: lisp
;; Package: emacs
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This takes a piece of Elisp code, and eliminates all free variables from
;; lambda expressions. The user entry points are cconv-closure-convert and
;; cconv-closure-convert-toplevel(for toplevel forms).
;; All macros should be expanded beforehand.
;;
;; Here is a brief explanation how this code works.
;; Firstly, we analyse the tree by calling cconv-analyse-form.
;; This function finds all mutated variables, all functions that are suitable
;; for lambda lifting and all variables captured by closure. It passes the tree
;; once, returning a list of three lists.
;;
;; Then we calculate the intersection of first and third lists returned by
;; cconv-analyse form to find all mutated variables that are captured by
;; closure.
;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
;; tree recursivly, lifting lambdas where possible, building closures where it
;; is needed and eliminating mutable variables used in closure.
;;
;; We do following replacements :
;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
;; if the function is suitable for lambda lifting (if all calls are known)
;;
;; (lambda (v0 ...) ... fv0 .. fv1 ...) =>
;; (internal-make-closure (v0 ...) (fv1 ...)
;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...)
;;
;; If the function has no free variables, we don't do anything.
;;
;; If a variable is mutated (updated by setq), and it is used in a closure
;; we wrap its definition with list: (list val) and we also replace
;; var => (car var) wherever this variable is used, and also
;; (setq var value) => (setcar var value) where it is updated.
;;
;; If defun argument is closure mutable, we letbind it and wrap it's
;; definition with list.
;; (defun foo (... mutable-arg ...) ...) =>
;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
;;
;;; Code:
;; TODO: (not just for cconv but also for the lexbind changes in general)
;; - let (e)debug find the value of lexical variables from the stack.
;; - make eval-region do the eval-sexp-add-defvars danse.
;; - byte-optimize-form should be applied before cconv.
;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
;; since afterwards they can because obnoxious (warnings about an "unused
;; variable" should not be emitted when the variable use has simply been
;; optimized away).
;; - turn defun and defmacro into macros (and remove special handling of
;; `declare' afterwards).
;; - let macros specify that some let-bindings come from the same source,
;; so the unused warning takes all uses into account.
;; - let interactive specs return a function to build the args (to stash into
;; command-history).
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities.
;; - new byte codes for unwind-protect, catch, and condition-case so that
;; closures aren't needed at all.
;; - inline source code of different binding mode by first compiling it.
;; - a reference to a var that is known statically to always hold a constant
;; should be turned into a byte-constant rather than a byte-stack-ref.
;; Hmm... right, that's called constant propagation and could be done here,
;; but when that constant is a function, we have to be careful to make sure
;; the bytecomp only compiles it once.
;; - Since we know here when a variable is not mutated, we could pass that
;; info to the byte-compiler, e.g. by using a new `immutable-let'.
;; - add tail-calls to bytecode.c and the byte compiler.
;; - call known non-escaping functions with `goto' rather than `call'.
;; - optimize mapcar to a while loop.
;; (defmacro dlet (binders &rest body)
;; ;; Works in both lexical and non-lexical mode.
;; `(progn
;; ,@(mapcar (lambda (binder)
;; `(defvar ,(if (consp binder) (car binder) binder)))
;; binders)
;; (let ,binders ,@body)))
;; (defmacro llet (binders &rest body)
;; ;; Only works in lexical-binding mode.
;; `(funcall
;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
;; binders)
;; ,@body)
;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
;; binders)))
;; (defmacro letrec (binders &rest body)
;; ;; Only useful in lexical-binding mode.
;; ;; As a special-form, we could implement it more efficiently (and cleanly,
;; ;; making the vars actually unbound during evaluation of the binders).
;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
;; binders)
;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder)))
;; binders))
;; ,@body))
(eval-when-compile (require 'cl))
(defconst cconv-liftwhen 6
"Try to do lambda lifting if the number of arguments + free variables
is less than this number.")
;; List of all the variables that are both captured by a closure
;; and mutated. Each entry in the list takes the form
;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
;; variable (or is just (VAR) for variables not introduced by let).
(defvar cconv-captured+mutated)
;; List of candidates for lambda lifting.
;; Each candidate has the form (BINDER . PARENTFORM). A candidate
;; is a variable that is only passed to `funcall' or `apply'.
(defvar cconv-lambda-candidates)
;; Alist associating to each function body the list of its free variables.
(defvar cconv-freevars-alist)
;;;###autoload
(defun cconv-closure-convert (form)
"Main entry point for closure conversion.
-- FORM is a piece of Elisp code after macroexpansion.
-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
Returns a form where all lambdas don't have any free variables."
;; (message "Entering cconv-closure-convert...")
(let ((cconv-freevars-alist '())
(cconv-lambda-candidates '())
(cconv-captured+mutated '()))
;; Analyse form - fill these variables with new information.
(cconv-analyse-form form '())
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
(cconv-convert form nil nil))) ; Env initially empty.
(defconst cconv--dummy-var (make-symbol "ignored"))
(defun cconv--set-diff (s1 s2)
"Return elements of set S1 that are not in set S2."
(let ((res '()))
(dolist (x s1)
(unless (memq x s2) (push x res)))
(nreverse res)))
(defun cconv--set-diff-map (s m)
"Return elements of set S that are not in Dom(M)."
(let ((res '()))
(dolist (x s)
(unless (assq x m) (push x res)))
(nreverse res)))
(defun cconv--map-diff (m1 m2)
"Return the submap of map M1 that has Dom(M2) removed."
(let ((res '()))
(dolist (x m1)
(unless (assq (car x) m2) (push x res)))
(nreverse res)))
(defun cconv--map-diff-elem (m x)
"Return the map M minus any mapping for X."
;; Here we assume that X appears at most once in M.
(let* ((b (assq x m))
(res (if b (remq b m) m)))
(assert (null (assq x res))) ;; Check the assumption was warranted.
res))
(defun cconv--map-diff-set (m s)
"Return the map M minus any mapping for elements of S."
;; Here we assume that X appears at most once in M.
(let ((res '()))
(dolist (b m)
(unless (memq (car b) s) (push b res)))
(nreverse res)))
(defun cconv--convert-function (args body env parentform)
(assert (equal body (caar cconv-freevars-alist)))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
(letbind '())
(envector ())
(i 0)
(new-env ()))
;; Build the "formal and actual envs" for the closure-converted function.
(dolist (fv fvs)
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
;; If `fv' is a variable that's wrapped in a cons-cell,
;; we want to put the cons-cell itself in the closure,
;; rather than just a copy of its current content.
(`(car ,iexp . ,_)
(push iexp envector)
(push `(,fv . (car (internal-get-closed-var ,i))) new-env))
(_
(push exp envector)
(push `(,fv . (internal-get-closed-var ,i)) new-env))))
(setq i (1+ i)))
(setq envector (nreverse envector))
(setq new-env (nreverse new-env))
(dolist (arg args)
(if (not (member (cons (list arg) parentform) cconv-captured+mutated))
(if (assq arg new-env) (push `(,arg) new-env))
(push `(,arg . (car ,arg)) new-env)
(push `(,arg (list ,arg)) letbind)))
(setq body-new (mapcar (lambda (form)
(cconv-convert form new-env nil))
body))
(when letbind
(let ((special-forms '()))
;; Keep special forms at the beginning of the body.
(while (or (stringp (car body-new)) ;docstring.
(memq (car-safe (car body-new)) '(interactive declare)))
(push (pop body-new) special-forms))
(setq body-new
`(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
(cond
((null envector) ;if no freevars - do nothing
`(function (lambda ,args . ,body-new)))
(t
`(internal-make-closure
,args ,envector . ,body-new)))))
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
"Return FORM with all its lambdas changed so they are closed.
ENV is a lexical environment mapping variables to the expression
used to get its value. This is used for variables that are copied into
closures, moved into cons cells, ...
ENV is a list where each entry takes the shape either:
(VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP
is an expression that evaluates to this cons-cell.
(VAR . (internal-get-closed-var N)): VAR has been copied into the closure
environment's Nth slot.
(VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
additional arguments ARGs.
EXTEND is a list of variables which might need to be accessed even from places
where they are shadowed, because some part of ENV causes them to be used at
places where they originally did not directly appear."
(assert (not (delq nil (mapcar (lambda (mapping)
(if (eq (cadr mapping) 'apply-partially)
(cconv--set-diff (cdr (cddr mapping))
extend)))
env))))
;; What's the difference between fvrs and envs?
;; Suppose that we have the code
;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
;; only the first occurrence of fvr should be replaced by
;; (aref env ...).
;; So initially envs and fvrs are the same thing, but when we descend to
;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
;; Because in envs the order of variables is important. We use this list
;; to find the number of a specific variable in the environment vector,
;; so we never touch it(unless we enter to the other closure).
;;(if (listp form) (print (car form)) form)
(pcase form
(`(,(and letsym (or `let* `let)) ,binders . ,body)
; let and let* special forms
(let ((binders-new '())
(new-env env)
(new-extend extend))
(dolist (binder binders)
(let* ((value nil)
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(setq value (cadr binder))
(car binder)))
(new-val
(cond
;; Check if var is a candidate for lambda lifting.
((and (member (cons binder form) cconv-lambda-candidates)
(progn
(assert (and (eq (car value) 'function)
(eq (car (cadr value)) 'lambda)))
(assert (equal (cddr (cadr value))
(caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs)))
; lambda lifting condition
(and fvs (>= cconv-liftwhen (length funcvars))))))
; Lift.
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs))
(funcbody (cddr fun))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
(pushnew fv new-extend)
(if (and (eq 'car (car-safe (cdr (assq fv env))))
(not (memq fv funargs)))
(push `(,fv . (car ,fv)) funcbody-env)))
`(function (lambda ,funcvars .
,(mapcar (lambda (form)
(cconv-convert
form funcbody-env nil))
funcbody)))))
;; Check if it needs to be turned into a "ref-cell".
((member (cons binder form) cconv-captured+mutated)
;; Declared variable is mutated and captured.
(push `(,var . (car ,var)) new-env)
`(list ,(cconv-convert value env extend)))
;; Normal default case.
(t
(if (assq var new-env) (push `(,var) new-env))
(cconv-convert value env extend)))))
;; The piece of code below letbinds free variables of a λ-lifted
;; function if they are redefined in this let, example:
;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
;; Here we can not pass y as parameter because it is redefined.
;; So we add a (closed-y y) declaration. We do that even if the
;; function is not used inside this let(*). The reason why we
;; ignore this case is that we can't "look forward" to see if the
;; function is called there or not. To treat this case better we'd
;; need to traverse the tree one more time to collect this data, and
;; I think that it's not worth it.
(when (memq var new-extend)
(let ((closedsym
(make-symbol (concat "closed-" (symbol-name var)))))
(setq new-env
(mapcar (lambda (mapping)
(if (not (eq (cadr mapping) 'apply-partially))
mapping
(assert (eq (car mapping) (nth 2 mapping)))
(list* (car mapping)
'apply-partially
(car mapping)
(mapcar (lambda (arg)
(if (eq var arg)
closedsym arg))
(nthcdr 3 mapping)))))
new-env))
(setq new-extend (remq var new-extend))
(push closedsym new-extend)
(push `(,closedsym ,var) binders-new)))
;; We push the element after redefined free variables are
;; processed. This is important to avoid the bug when free
;; variable and the function have the same name.
(push (list var new-val) binders-new)
(when (eq letsym 'let*)
(setq env new-env)
(setq extend new-extend))
)) ; end of dolist over binders
`(,letsym ,(nreverse binders-new)
. ,(mapcar (lambda (form)
(cconv-convert
form new-env new-extend))
body))))
;end of let let* forms
; first element is lambda expression
(`(,(and `(lambda . ,_) fun) . ,args)
;; FIXME: it's silly to create a closure just to call it.
;; Running byte-optimize-form earlier will resolve this.
`(funcall
,(cconv-convert `(function ,fun) env extend)
,@(mapcar (lambda (form)
(cconv-convert form env extend))
args)))
(`(cond . ,cond-forms) ; cond special form
`(cond . ,(mapcar (lambda (branch)
(mapcar (lambda (form)
(cconv-convert form env extend))
branch))
cond-forms)))
(`(function (lambda ,args . ,body) . ,_)
(cconv--convert-function args body env form))
(`(internal-make-closure . ,_)
(byte-compile-report-error
"Internal error in compiler: cconv called twice?"))
(`(quote . ,_) form)
(`(function . ,_) form)
;defconst, defvar
(`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms)
`(,sym ,definedsymbol
. ,(mapcar (lambda (form) (cconv-convert form env extend))
forms)))
;defun, defmacro
(`(,(and sym (or `defun `defmacro))
,func ,args . ,body)
(assert (equal body (caar cconv-freevars-alist)))
(assert (null (cdar cconv-freevars-alist)))
(let ((new (cconv--convert-function args body env form)))
(pcase new
(`(function (lambda ,newargs . ,new-body))
(assert (equal args newargs))
`(,sym ,func ,args . ,new-body))
(t (byte-compile-report-error
(format "Internal error in cconv of (%s %s ...)" sym func))))))
;condition-case
(`(condition-case ,var ,protected-form . ,handlers)
(let ((newform (cconv--convert-function
() (list protected-form) env form)))
`(condition-case :fun-body ,newform
,@(mapcar (lambda (handler)
(list (car handler)
(cconv--convert-function
(list (or var cconv--dummy-var))
(cdr handler) env form)))
handlers))))
(`(,(and head (or `catch `unwind-protect)) ,form . ,body)
`(,head ,(cconv-convert form env extend)
:fun-body ,(cconv--convert-function () body env form)))
(`(track-mouse . ,body)
`(track-mouse
:fun-body ,(cconv--convert-function () body env form)))
(`(setq . ,forms) ; setq special form
(let ((prognlist ()))
(while forms
(let* ((sym (pop forms))
(sym-new (or (cdr (assq sym env)) sym))
(value (cconv-convert (pop forms) env extend)))
(push (pcase sym-new
((pred symbolp) `(setq ,sym-new ,value))
(`(car ,iexp) `(setcar ,iexp ,value))
;; This "should never happen", but for variables which are
;; mutated+captured+unused, we may end up trying to `setq'
;; on a closed-over variable, so just drop the setq.
(_ ;; (byte-compile-report-error
;; (format "Internal error in cconv of (setq %s ..)"
;; sym-new))
value))
prognlist)))
(if (cdr prognlist)
`(progn . ,(nreverse prognlist))
(car prognlist))))
(`(,(and (or `funcall `apply) callsym) ,fun . ,args)
;; These are not special forms but we treat them separately for the needs
;; of lambda lifting.
(let ((mapping (cdr (assq fun env))))
(pcase mapping
(`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
(assert (eq (cadr mapping) fun))
`(,callsym ,fun
,@(mapcar (lambda (fv)
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
(`(car ,iexp . ,_) iexp)
(_ exp))))
fvs)
,@(mapcar (lambda (arg)
(cconv-convert arg env extend))
args)))
(_ `(,callsym ,@(mapcar (lambda (arg)
(cconv-convert arg env extend))
(cons fun args)))))))
(`(interactive . ,forms)
`(interactive . ,(mapcar (lambda (form)
(cconv-convert form nil nil))
forms)))
(`(declare . ,_) form) ;The args don't contain code.
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
;; if, progn, prog1, prog2, while, until
`(,func . ,(mapcar (lambda (form)
(cconv-convert form env extend))
forms)))
(_ (or (cdr (assq form env)) form))))
(unless (fboundp 'byte-compile-not-lexical-var-p)
;; Only used to test the code in non-lexbind Emacs.
(defalias 'byte-compile-not-lexical-var-p 'boundp))
(defun cconv--analyse-use (vardata form varkind)
"Analyse the use of a variable.
VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
VARKIND is the name of the kind of variable.
FORM is the parent form that binds this var."
;; use = `(,binder ,read ,mutated ,captured ,called)
(pcase vardata
(`(,_ nil nil nil nil) nil)
(`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_)
,_ ,_ ,_ ,_)
(byte-compile-log-warning
(format "%s `%S' not left unused" varkind var))))
(pcase vardata
(`((,var . ,_) nil ,_ ,_ nil)
;; FIXME: This gives warnings in the wrong order, with imprecise line
;; numbers and without function name info.
(unless (or ;; Uninterned symbols typically come from macro-expansion, so
;; it is often non-trivial for the programmer to avoid such
;; unused vars.
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0)))
(byte-compile-log-warning (format "Unused lexical %s `%S'"
varkind var))))
;; If it's unused, there's no point converting it into a cons-cell, even if
;; it's captured and mutated.
(`(,binder ,_ t t ,_)
(push (cons binder form) cconv-captured+mutated))
(`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
(push (cons binder form) cconv-lambda-candidates))))
(defun cconv--analyse-function (args body env parentform)
(let* ((newvars nil)
(freevars (list body))
;; We analyze the body within a new environment where all uses are
;; nil, so we can distinguish uses within that function from uses
;; outside of it.
(envcopy
(mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
(newenv envcopy))
;; Push it before recursing, so cconv-freevars-alist contains entries in
;; the order they'll be used by closure-convert-rec.
(push freevars cconv-freevars-alist)
(dolist (arg args)
(cond
((byte-compile-not-lexical-var-p arg)
(byte-compile-log-warning
(format "Argument %S is not a lexical variable" arg)))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
(t (let ((varstruct (list arg nil nil nil nil)))
(push (cons (list arg) (cdr varstruct)) newvars)
(push varstruct newenv)))))
(dolist (form body) ;Analyse body forms.
(cconv-analyse-form form newenv))
;; Summarize resulting data about arguments.
(dolist (vardata newvars)
(cconv--analyse-use vardata parentform "argument"))
;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
;; and compute free variables.
(while env
(assert (and envcopy (eq (caar env) (caar envcopy))))
(let ((free nil)
(x (cdr (car env)))
(y (cdr (car envcopy))))
(while x
(when (car y) (setcar x t) (setq free t))
(setq x (cdr x) y (cdr y)))
(when free
(push (caar env) (cdr freevars))
(setf (nth 3 (car env)) t))
(setq env (cdr env) envcopy (cdr envcopy))))))
(defun cconv-analyse-form (form env)
"Find mutated variables and variables captured by closure.
Analyse lambdas if they are suitable for lambda lifting.
- FORM is a piece of Elisp code after macroexpansion.
- ENV is an alist mapping each enclosing lexical variable to its info.
I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
This function does not return anything but instead fills the
`cconv-captured+mutated' and `cconv-lambda-candidates' variables
and updates the data stored in ENV."
(pcase form
; let special form
(`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
(let ((orig-env env)
(newvars nil)
(var nil)
(value nil))
(dolist (binder binders)
(if (not (consp binder))
(progn
(setq var binder) ; treat the form (let (x) ...) well
(setq binder (list binder))
(setq value nil))
(setq var (car binder))
(setq value (cadr binder))
(cconv-analyse-form value (if (eq letsym 'let*) env orig-env)))
(unless (byte-compile-not-lexical-var-p var)
(let ((varstruct (list var nil nil nil nil)))
(push (cons binder (cdr varstruct)) newvars)
(push varstruct env))))
(dolist (form body-forms) ; Analyse body forms.
(cconv-analyse-form form env))
(dolist (vardata newvars)
(cconv--analyse-use vardata form "variable"))))
; defun special form
(`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
(when env
(byte-compile-log-warning
(format "Function %S will ignore its context %S"
func (mapcar #'car env))
t :warning))
(cconv--analyse-function vrs body-forms nil form))
(`(function (lambda ,vrs . ,body-forms))
(cconv--analyse-function vrs body-forms env form))
(`(setq . ,forms)
;; If a local variable (member of env) is modified by setq then
;; it is a mutated variable.
(while forms
(let ((v (assq (car forms) env))) ; v = non nil if visible
(when v (setf (nth 2 v) t)))
(cconv-analyse-form (cadr forms) env)
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; first element is lambda expression
(dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyse-form exp env)))
(`(cond . ,cond-forms) ; cond special form
(dolist (forms cond-forms)
(dolist (form forms) (cconv-analyse-form form env))))
(`(quote . ,_) nil) ; quote form
(`(function . ,_) nil) ; same as quote
(`(condition-case ,var ,protected-form . ,handlers)
;; FIXME: The bytecode for condition-case forces us to wrap the
;; form and handlers in closures (for handlers, it's understandable
;; but not for the protected form).
(cconv--analyse-function () (list protected-form) env form)
(dolist (handler handlers)
(cconv--analyse-function (if var (list var)) (cdr handler) env form)))
;; FIXME: The bytecode for catch forces us to wrap the body.
(`(,(or `catch `unwind-protect) ,form . ,body)
(cconv-analyse-form form env)
(cconv--analyse-function () body env form))
;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
;; `track-mouse' really should be made into a macro.
(`(track-mouse . ,body)
(cconv--analyse-function () body env form))
(`(,(or `defconst `defvar) ,var ,value . ,_)
(push var byte-compile-bound-variables)
(cconv-analyse-form value env))
(`(,(or `funcall `apply) ,fun . ,args)
;; Here we ignore fun because funcall and apply are the only two
;; functions where we can pass a candidate for lambda lifting as
;; argument. So, if we see fun elsewhere, we'll delete it from
;; lambda candidate list.
(let ((fdata (and (symbolp fun) (assq fun env))))
(if fdata
(setf (nth 4 fdata) t)
(cconv-analyse-form fun env)))
(dolist (form args) (cconv-analyse-form form env)))
(`(interactive . ,forms)
;; These appear within the function body but they don't have access
;; to the function's arguments.
;; We could extend this to allow interactive specs to refer to
;; variables in the function's enclosing environment, but it doesn't
;; seem worth the trouble.
(dolist (form forms) (cconv-analyse-form form nil)))
(`(declare . ,_) nil) ;The args don't contain code.
(`(,_ . ,body-forms) ; First element is a function or whatever.
(dolist (form body-forms) (cconv-analyse-form form env)))
((pred symbolp)
(let ((dv (assq form env))) ; dv = declared and visible
(when dv
(setf (nth 1 dv) t))))))
(provide 'cconv)
;;; cconv.el ends here

23
lisp/emacs-lisp/cl-extra.el
View File

@ -766,20 +766,15 @@ This also does some trivial optimizations to make the form prettier."
(eq (car-safe (car body)) 'interactive))
(push (list 'quote (pop body)) decls))
(put (car (last cl-closure-vars)) 'used t)
(append
(list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
(sublis sub (nreverse decls))
(list
(list* 'list '(quote apply)
(list 'function
(list* 'lambda
(append new (cadadr form))
(sublis sub body)))
(nconc (mapcar (function
(lambda (x)
(list 'list '(quote quote) x)))
cl-closure-vars)
'((quote --cl-rest--)))))))
`(list 'lambda '(&rest --cl-rest--)
,@(sublis sub (nreverse decls))
(list 'apply
(list 'quote
#'(lambda ,(append new (cadadr form))
,@(sublis sub body)))
,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
cl-closure-vars)
'((quote --cl-rest--))))))
(list (car form) (list* 'lambda (cadadr form) body))))
(let ((found (assq (cadr form) env)))
(if (and found (ignore-errors

39
lisp/emacs-lisp/cl-loaddefs.el
View File

@ -10,7 +10,7 @@
;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
;;;;;; notevery notany every some mapcon mapcan mapl maplist map
;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "60f6b85256416c5f2a0a3954a11523b6")
;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84")
;;; Generated autoloads from cl-extra.el
(autoload 'coerce "cl-extra" "\
@ -277,12 +277,12 @@ Not documented
;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct
;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf
;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method
;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let*
;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq
;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from
;;;;;; return block etypecase typecase ecase case load-time-value
;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp
;;;;;; gensym) "cl-macs" "cl-macs.el" "b3031039e82679e5b013ce1cbf174ee8")
;;;;;; declare the locally multiple-value-setq multiple-value-bind
;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels
;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
;;;;;; do* do loop return-from return block etypecase typecase ecase
;;;;;; case load-time-value eval-when destructuring-bind function*
;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions.
\(fn FUNC)" nil (quote macro))
(autoload 'destructuring-bind "cl-macs" "\
Not documented
\(fn ARGS EXPR &rest BODY)" nil (quote macro))
@ -445,7 +445,7 @@ from OBARRAY.
\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro))
(autoload 'do-all-symbols "cl-macs" "\
Not documented
\(fn SPEC &rest BODY)" nil (quote macro))
@ -500,16 +500,16 @@ Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
\(fn VARLIST BODY)" nil (quote macro))
\(fn BINDINGS BODY)" nil (quote macro))
(autoload 'lexical-let* "cl-macs" "\
Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
successive bindings within VARLIST, will create lexical closures
successive bindings within BINDINGS, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
\(fn VARLIST BODY)" nil (quote macro))
\(fn BINDINGS BODY)" nil (quote macro))
(autoload 'multiple-value-bind "cl-macs" "\
Collect multiple return values.
@ -531,12 +531,17 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)" nil (quote macro))
(autoload 'locally "cl-macs" "\
Not documented
\(fn &rest BODY)" nil (quote macro))
(autoload 'the "cl-macs" "\
\(fn TYPE FORM)" nil (quote macro))
(autoload 'declare "cl-macs" "\
Not documented
\(fn &rest SPECS)" nil (quote macro))
@ -596,7 +601,7 @@ before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)" nil (quote macro))
(autoload 'cl-do-pop "cl-macs" "\
Not documented
\(fn PLACE)" nil nil)
@ -684,7 +689,7 @@ value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)" nil (quote macro))
(autoload 'cl-struct-setf-expander "cl-macs" "\
Not documented
\(fn X NAME ACCESSOR PRED-FORM POS)" nil nil)
@ -730,7 +735,7 @@ and then returning foo.
\(fn FUNC ARGS &rest BODY)" nil (quote macro))
(autoload 'compiler-macroexpand "cl-macs" "\
Not documented
\(fn FORM)" nil nil)

64
lisp/emacs-lisp/cl-macs.el
View File

@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
(print set (symbol-value 'bytecomp-outbuffer)))
(print set (symbol-value 'byte-compile--outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
@ -598,27 +598,6 @@ called from BODY."
(list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
body))))
(defvar cl-active-block-names nil)
(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
(defun cl-byte-compile-block (cl-form)
(if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
(progn
(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
(cl-active-block-names (cons cl-entry cl-active-block-names))
(cl-body (byte-compile-top-level
(cons 'progn (cddr (nth 1 cl-form))))))
(if (cdr cl-entry)
(byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
(byte-compile-form cl-body))))
(byte-compile-form (nth 1 cl-form))))
(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
(defun cl-byte-compile-throw (cl-form)
(let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
(if cl-found (setcdr cl-found t)))
(byte-compile-normal-call (cons 'throw (cdr cl-form))))
;;;###autoload
(defmacro return (&optional result)
"Return from the block named nil.
@ -1427,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
\n(fn VARLIST BODY)"
\n(fn BINDINGS BODY)"
(let* ((cl-closure-vars cl-closure-vars)
(vars (mapcar (function
(lambda (x)
@ -1470,10 +1449,10 @@ lexical closures as in Common Lisp.
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
successive bindings within VARLIST, will create lexical closures
successive bindings within BINDINGS, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
\n(fn VARLIST BODY)"
\n(fn BINDINGS BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
@ -2422,11 +2401,13 @@ value, that slot cannot be set via `setf'.
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
(if print-func
(push (list 'push
(list 'function
(list 'lambda '(cl-x cl-s cl-n)
(list 'and pred-form print-func)))
'custom-print-functions) forms))
(push `(push
;; The auto-generated function does not pay attention to
;; the depth argument cl-n.
(lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
(and ,pred-form ,print-func))
custom-print-functions)
forms))
(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
(push (list* 'eval-when '(compile load eval)
(list 'put (list 'quote name) '(quote cl-struct-slots)
@ -2580,7 +2561,7 @@ and then returning foo."
(cl-transform-function-property
func 'cl-compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
(cons '--cl-whole-arg-- args)) body))
(cons '_cl-whole-arg args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'progn
(list 'put (list 'quote func) '(quote byte-compile)
@ -2618,6 +2599,27 @@ and then returning foo."
(byte-compile-normal-call form)
(byte-compile-form form)))
;; Optimize away unused block-wrappers.
(defvar cl-active-block-names nil)
(define-compiler-macro cl-block-wrapper (cl-form)
(let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
(cl-active-block-names (cons cl-entry cl-active-block-names))
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
(cons 'progn (cddr cl-form))
macroexpand-all-environment)))
;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
;; to indicate that this return value is already fully expanded.
(if (cdr cl-entry)
`(catch ,(nth 1 cl-form) ,@(cdr cl-body))
cl-body)))
(define-compiler-macro cl-block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
;;;###autoload
(defmacro defsubst* (name args &rest body)
"Define NAME as a function.

15
lisp/emacs-lisp/cl.el
View File

@ -161,7 +161,14 @@ an element already on the list.
(if (symbolp place)
(if (null keys)
`(let ((x ,x))
(if (memql x ,place) ,place (setq ,place (cons x ,place))))
(if (memql x ,place)
;; This symbol may later on expand to actual code which then
;; trigger warnings like "value unused" since pushnew's return
;; value is rarely used. It should not matter that other
;; warnings may be silenced, since `place' is used earlier and
;; should have triggered them already.
(with-no-warnings ,place)
(setq ,place (cons x ,place))))
(list 'setq place (list* 'adjoin x place keys)))
(list* 'callf2 'adjoin x place keys)))
@ -271,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
(and (boundp 'bytecomp-outbuffer)
(bufferp (symbol-value 'bytecomp-outbuffer))
(equal (buffer-name (symbol-value 'bytecomp-outbuffer))
(and (boundp 'byte-compile--outbuffer)
(bufferp (symbol-value 'byte-compile--outbuffer))
(equal (buffer-name (symbol-value 'byte-compile--outbuffer))
" *Compiler Output*"))))
(defvar cl-proclaims-deferred nil)

13
lisp/emacs-lisp/disass.el
View File

@ -78,13 +78,14 @@ redefine OBJECT if it is a symbol."
obj (symbol-function obj)))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
(if (and (listp obj) (eq (car obj) 'autoload))
(progn
(load (nth 1 obj))
(setq obj (symbol-function name))))
(when (and (listp obj) (eq (car obj) 'autoload))
(load (nth 1 obj))
(setq obj (symbol-function name)))
(if (eq (car-safe obj) 'macro) ;handle macros
(setq macro t
obj (cdr obj)))
(when (and (listp obj) (eq (car obj) 'closure))
(error "Don't know how to compile an interpreted closure"))
(if (and (listp obj) (eq (car obj) 'byte-code))
(setq obj (list 'lambda nil obj)))
(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."
(cond ((memq op byte-goto-ops)
(insert (int-to-string (nth 1 arg))))
((memq op '(byte-call byte-unbind
byte-listN byte-concatN byte-insertN))
byte-listN byte-concatN byte-insertN
byte-stack-ref byte-stack-set byte-stack-set2
byte-discardN byte-discardN-preserve-tos))
(insert (int-to-string arg)))
((memq op '(byte-varref byte-varset byte-varbind))
(prin1 (car arg) (current-buffer)))

21
lisp/emacs-lisp/edebug.el
View File

@ -519,7 +519,8 @@ the minibuffer."
((and (eq (car form) 'defcustom)
(default-boundp (nth 1 form)))
;; Force variable to be bound.
(set-default (nth 1 form) (eval (nth 2 form))))
;; FIXME: Shouldn't this use the :setter or :initializer?
(set-default (nth 1 form) (eval (nth 2 form) lexical-binding)))
((eq (car form) 'defface)
;; Reset the face.
(setq face-new-frame-defaults
@ -532,7 +533,7 @@ the minibuffer."
(put ',(nth 1 form) 'customized-face
,(nth 2 form)))
(put (nth 1 form) 'saved-face nil)))))
(setq edebug-result (eval form))
(setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding))
(if (not edebugging)
(princ edebug-result)
edebug-result)))
@ -565,7 +566,8 @@ already is one.)"
;; but this causes problems while edebugging edebug.
(let ((edebug-all-forms t)
(edebug-all-defs t))
(edebug-read-top-level-form))))
(eval-sexp-add-defvars
(edebug-read-top-level-form)))))
(defun edebug-read-top-level-form ()
@ -2462,6 +2464,7 @@ MSG is printed after `::::} '."
(if edebug-global-break-condition
(condition-case nil
(setq edebug-global-break-result
;; FIXME: lexbind.
(eval edebug-global-break-condition))
(error nil))))
(edebug-break))
@ -2473,6 +2476,7 @@ MSG is printed after `::::} '."
(and edebug-break-data
(or (not edebug-break-condition)
(setq edebug-break-result
;; FIXME: lexbind.
(eval edebug-break-condition))))))
(if (and edebug-break
(nth 2 edebug-break-data)) ; is it temporary?
@ -3633,9 +3637,10 @@ Return the result of the last expression."
(defun edebug-eval (edebug-expr)
;; Are there cl lexical variables active?
(if (bound-and-true-p cl-debug-env)
(eval (cl-macroexpand-all edebug-expr cl-debug-env))
(eval edebug-expr)))
(eval (if (bound-and-true-p cl-debug-env)
(cl-macroexpand-all edebug-expr cl-debug-env)
edebug-expr)
lexical-binding))
(defun edebug-safe-eval (edebug-expr)
;; Evaluate EXPR safely.
@ -4237,8 +4242,8 @@ It is removed when you hit any char."
;;; Menus
(defun edebug-toggle (variable)
(set variable (not (eval variable)))
(message "%s: %s" variable (eval variable)))
(set variable (not (symbol-value variable)))
(message "%s: %s" variable (symbol-value variable)))
;; We have to require easymenu (even for Emacs 18) just so
;; the easy-menu-define macro call is compiled correctly.

142
lisp/emacs-lisp/eieio-comp.el
View File

@ -1,142 +0,0 @@
;;; eieio-comp.el -- eieio routines to help with byte compilation
;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011
;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: lisp, tools
;; Package: eieio
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Byte compiler functions for defmethod. This will affect the new GNU
;; byte compiler for Emacs 19 and better. This function will be called by
;; the byte compiler whenever a `defmethod' is encountered in a file.
;; It will output a function call to `eieio-defmethod' with the byte
;; compiled function as a parameter.
;;; Code:
(declare-function eieio-defgeneric-form "eieio" (method doc-string))
;; Some compatibility stuff
(eval-and-compile
(if (not (fboundp 'byte-compile-compiled-obj-to-list))
(defun byte-compile-compiled-obj-to-list (moose) nil))
(if (not (boundp 'byte-compile-outbuffer))
(defvar byte-compile-outbuffer nil))
)
;; This teaches the byte compiler how to do this sort of thing.
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
(defun byte-compile-file-form-defmethod (form)
"Mumble about the method we are compiling.
This function is mostly ripped from `byte-compile-file-form-defun',
but it's been modified to handle the special syntax of the `defmethod'
command. There should probably be one for `defgeneric' as well, but
that is called but rarely. Argument FORM is the body of the method."
(setq form (cdr form))
(let* ((meth (car form))
(key (progn (setq form (cdr form))
(cond ((or (eq ':BEFORE (car form))
(eq ':before (car form)))
(setq form (cdr form))
":before ")
((or (eq ':AFTER (car form))
(eq ':after (car form)))
(setq form (cdr form))
":after ")
((or (eq ':PRIMARY (car form))
(eq ':primary (car form)))
(setq form (cdr form))
":primary ")
((or (eq ':STATIC (car form))
(eq ':static (car form)))
(setq form (cdr form))
":static ")
(t ""))))
(params (car form))
(lamparams (byte-compile-defmethod-param-convert params))
(arg1 (car params))
(class (if (listp arg1) (nth 1 arg1) nil))
(my-outbuffer (if (eval-when-compile (featurep 'xemacs))
byte-compile-outbuffer
(cond ((boundp 'bytecomp-outbuffer)
bytecomp-outbuffer) ; Emacs >= 23.2
((boundp 'outbuffer) outbuffer)
(t (error "Unable to set outbuffer"))))))
(let ((name (format "%s::%s" (or class "#<generic>") meth)))
(if byte-compile-verbose
;; #### filename used free
(message "Compiling %s... (%s)"
(cond ((boundp 'bytecomp-filename) bytecomp-filename)
((boundp 'filename) filename)
(t ""))
name))
(setq byte-compile-current-form name) ; for warnings
)
;; Flush any pending output
(byte-compile-flush-pending)
;; Byte compile the body. For the byte compiled forms, add the
;; rest arguments, which will get ignored by the engine which will
;; add them later (I hope)
(let* ((new-one (byte-compile-lambda
(append (list 'lambda lamparams)
(cdr form))))
(code (byte-compile-byte-code-maker new-one)))
(princ "\n(eieio-defmethod '" my-outbuffer)
(princ meth my-outbuffer)
(princ " '(" my-outbuffer)
(princ key my-outbuffer)
(prin1 params my-outbuffer)
(princ " " my-outbuffer)
(prin1 code my-outbuffer)
(princ "))" my-outbuffer)
)
;; Now add this function to the list of known functions.
;; Don't bother with a doc string. Not relevant here.
(add-to-list 'byte-compile-function-environment
(cons meth
(eieio-defgeneric-form meth "")))
;; Remove it from the undefined list if it is there.
(let ((elt (assq meth byte-compile-unresolved-functions)))
(if elt (setq byte-compile-unresolved-functions
(delq elt byte-compile-unresolved-functions))))
;; nil prevents cruft from appearing in the output buffer.
nil))
(defun byte-compile-defmethod-param-convert (paramlist)
"Convert method params into the params used by the `defmethod' thingy.
Argument PARAMLIST is the parameter list to convert."
(let ((argfix nil))
(while paramlist
(setq argfix (cons (if (listp (car paramlist))
(car (car paramlist))
(car paramlist))
argfix))
(setq paramlist (cdr paramlist)))
(nreverse argfix)))
(provide 'eieio-comp)
;;; eieio-comp.el ends here

57
lisp/emacs-lisp/eieio.el
View File

@ -45,8 +45,7 @@
;;; Code:
(eval-when-compile
(require 'cl)
(require 'eieio-comp))
(require 'cl))
(defvar eieio-version "1.3"
"Current version of EIEIO.")
@ -97,6 +96,7 @@ default setting for optimization purposes.")
"Non-nil means to optimize the method dispatch on primary methods.")
;; State Variables
;; FIXME: These two constants below should have an `eieio-' prefix added!!
(defvar this nil
"Inside a method, this variable is the object in question.
DO 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!")
;; while it is being built itself.
(defvar eieio-default-superclass nil)
;; FIXME: The constants below should have an `eieio-' prefix added!!
(defconst class-symbol 1 "Class's symbol (self-referencing.).")
(defconst class-parent 2 "Class parent slot.")
(defconst class-children 3 "Class children class slot.")
@ -181,10 +182,6 @@ Stored outright without modifications or stripping.")
(t key) ;; already generic.. maybe.
))
;; How to specialty compile stuff.
(autoload 'byte-compile-file-form-defmethod "eieio-comp"
"This function is used to byte compile methods in a nice way.")
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
;;; Important macros used in eieio.
;;
@ -1192,10 +1189,8 @@ IMPL is the symbol holding the method implementation."
;; is faster to execute this for not byte-compiled. ie, install this,
;; then measure calls going through here. I wonder why.
(require 'bytecomp)
(let ((byte-compile-free-references nil)
(byte-compile-warnings nil)
)
(byte-compile-lambda
(let ((byte-compile-warnings nil))
(byte-compile
`(lambda (&rest local-args)
,doc-string
;; 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."
;; of that one implementation, then clearly, there is no method def.
(if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal.
(signal 'no-method-definition (list ,(list 'quote method) local-args))
(signal 'no-method-definition
(list ,(list 'quote method) local-args))
;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass)
@ -1228,9 +1224,7 @@ IMPL is the symbol holding the method implementation."
)
(apply ,(list 'quote impl) local-args)
;(,impl local-args)
))))
)
))
)))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form."
@ -1296,9 +1290,35 @@ Summary:
((typearg class-name) arg2 &optional opt &rest rest)
\"doc-string\"
body)"
`(eieio-defmethod (quote ,method) (quote ,args)))
(let* ((key (cond ((or (eq ':BEFORE (car args))
(eq ':before (car args)))
(setq args (cdr args))
:before)
((or (eq ':AFTER (car args))
(eq ':after (car args)))
(setq args (cdr args))
:after)
((or (eq ':PRIMARY (car args))
(eq ':primary (car args)))
(setq args (cdr args))
:primary)
((or (eq ':STATIC (car args))
(eq ':static (car args)))
(setq args (cdr args))
:static)
(t nil)))
(params (car args))
(lamparams
(mapcar (lambda (param) (if (listp param) (car param) param))
params))
(arg1 (car params))
(class (if (listp arg1) (nth 1 arg1) nil)))
`(eieio-defmethod ',method
'(,@(if key (list key))
,params)
(lambda ,lamparams ,@(cdr args)))))
(defun eieio-defmethod (method args)
(defun eieio-defmethod (method args &optional code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
(let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
;; find optional keys
@ -1352,10 +1372,7 @@ Summary:
;; generics are higher
(setq key (eieio-specialized-key-to-generic-key key)))
;; Put this lambda into the symbol so we can find it
(if (byte-code-function-p (car-safe body))
(eieiomt-add method (car-safe body) key argclass)
(eieiomt-add method (append (list 'lambda (reverse argfix)) body)
key argclass))
(eieiomt-add method code key argclass)
)
(when eieio-optimize-primary-methods-flag

8
lisp/emacs-lisp/float-sup.el
View File

@ -28,7 +28,13 @@
;; Provide an easy hook to tell if we are running with floats or not.
;; Define pi and e via math-lib calls (much less prone to killer typos).
(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")
(progn
;; Simulate a defconst that doesn't declare the variable dynamically bound.
(setq-default pi float-pi)
(put 'pi 'variable-documentation
"Obsolete since Emacs-23.3. Use `float-pi' instead.")
(put 'pi 'risky-local-variable t)
(push 'pi current-load-list))
(defconst float-e (exp 1) "The value of e (2.7182818...).")

37
lisp/emacs-lisp/lisp-mode.el
View File

@ -699,7 +699,9 @@ If CHAR is not a character, return nil."
"Evaluate sexp before point; print value in minibuffer.
With argument, print output into current buffer."
(let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)))
(eval-last-sexp-print-value (eval (preceding-sexp)))))
;; Setup the lexical environment if lexical-binding is enabled.
(eval-last-sexp-print-value
(eval (eval-sexp-add-defvars (preceding-sexp)) lexical-binding))))
(defun eval-last-sexp-print-value (value)
@ -727,6 +729,23 @@ With argument, print output into current buffer."
(defvar eval-last-sexp-fake-value (make-symbol "t"))
(defun eval-sexp-add-defvars (exp &optional pos)
"Prepend EXP with all the `defvar's that precede it in the buffer.
POS specifies the starting position where EXP was found and defaults to point."
(if (not lexical-binding)
exp
(save-excursion
(unless pos (setq pos (point)))
(let ((vars ()))
(goto-char (point-min))
(while (re-search-forward
"^(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
pos t)
(let ((var (intern (match-string 1))))
(unless (special-variable-p var)
(push var vars))))
`(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
(defun eval-last-sexp (eval-last-sexp-arg-internal)
"Evaluate sexp before point; print value in minibuffer.
Interactively, with prefix argument, print output into current buffer.
@ -763,16 +782,18 @@ Reinitialize the face according to the `defface' specification."
;; `defcustom' is now macroexpanded to
;; `custom-declare-variable' with a quoted value arg.
((and (eq (car form) 'custom-declare-variable)
(default-boundp (eval (nth 1 form))))
(default-boundp (eval (nth 1 form) lexical-binding)))
;; Force variable to be bound.
(set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form))))
(set-default (eval (nth 1 form) lexical-binding)
(eval (nth 1 (nth 2 form)) lexical-binding))
form)
;; `defface' is macroexpanded to `custom-declare-face'.
((eq (car form) 'custom-declare-face)
;; Reset the face.
(setq face-new-frame-defaults
(assq-delete-all (eval (nth 1 form)) face-new-frame-defaults))
(put (eval (nth 1 form)) 'face-defface-spec nil)
(assq-delete-all (eval (nth 1 form) lexical-binding)
face-new-frame-defaults))
(put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil)
;; Setting `customized-face' to the new spec after calling
;; the form, but preserving the old saved spec in `saved-face',
;; imitates the situation when the new face spec is set
@ -783,10 +804,11 @@ Reinitialize the face according to the `defface' specification."
;; `defface' change the spec, regardless of a saved spec.
(prog1 `(prog1 ,form
(put ,(nth 1 form) 'saved-face
',(get (eval (nth 1 form)) 'saved-face))
',(get (eval (nth 1 form) lexical-binding)
'saved-face))
(put ,(nth 1 form) 'customized-face
,(nth 2 form)))
(put (eval (nth 1 form)) 'saved-face nil)))
(put (eval (nth 1 form) lexical-binding) 'saved-face nil)))
((eq (car form) 'progn)
(cons 'progn (mapcar 'eval-defun-1 (cdr form))))
(t form)))
@ -1205,7 +1227,6 @@ This function also returns nil meaning don't specify the indentation."
(put 'prog1 'lisp-indent-function 1)
(put 'prog2 'lisp-indent-function 2)
(put 'save-excursion 'lisp-indent-function 0)
(put 'save-window-excursion 'lisp-indent-function 0)
(put 'save-restriction 'lisp-indent-function 0)
(put 'save-match-data 'lisp-indent-function 0)
(put 'save-current-buffer 'lisp-indent-function 0)

43
lisp/emacs-lisp/macroexp.el
View File

@ -1,4 +1,4 @@
;;; macroexp.el --- Additional macro-expansion support
;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
;;
;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
;;
@ -29,6 +29,8 @@
;;; Code:
(eval-when-compile (require 'cl))
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@ -106,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
(macroexpand (macroexpand-all-forms form 1)
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(setq form (macroexpand form macroexpand-all-environment))
(let ((new-form (macroexpand form macroexpand-all-environment)))
(when (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
(symbolp (car form))
(get (car form) 'byte-obsolete-info)
(fboundp 'byte-compile-warn-obsolete))
(byte-compile-warn-obsolete (car form)))
(setq form new-form))
(pcase form
(`(cond . ,clauses)
(maybe-cons 'cond (macroexpand-all-clauses clauses) form))
@ -122,7 +131,16 @@ Assumes the caller has bound `macroexpand-all-environment'."
(`(defmacro ,name . ,args-and-body)
(push (cons name (cons 'lambda args-and-body))
macroexpand-all-environment)
(macroexpand-all-forms form 3))
(let ((n 3))
;; Don't macroexpand `declare' since it should really be "expanded"
;; away when `defmacro' is expanded, but currently defmacro is not
;; itself a macro. So both `defmacro' and `declare' need to be
;; handled directly in bytecomp.el.
;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote).
(while (or (stringp (nth n form))
(eq (car-safe (nth n form)) 'declare))
(setq n (1+ n)))
(macroexpand-all-forms form n)))
(`(defun . ,_) (macroexpand-all-forms form 3))
(`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2))
(`(function ,(and f `(lambda . ,_)))
@ -151,19 +169,34 @@ Assumes the caller has bound `macroexpand-all-environment'."
;; here, so that any code that cares about the difference will
;; see the same transformation.
;; First arg is a function:
(`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args)
(`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc))
',(and f `(lambda . ,_)) . ,args)
;; We don't use `maybe-cons' since there's clearly a change.
(cons fun
(cons (macroexpand-all-1 (list 'function f))
(macroexpand-all-forms args))))
;; Second arg is a function:
(`(,(and fun (or `sort)) ,arg1 ',f . ,args)
(`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
;; We don't use `maybe-cons' since there's clearly a change.
(cons fun
(cons (macroexpand-all-1 arg1)
(cons (macroexpand-all-1
(list 'function f))
(macroexpand-all-forms args)))))
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
;; use macros.
;; FIXME: Don't depend on CL.
(`(,(pred (lambda (fun)
(and (symbolp fun)
(eq (get fun 'byte-compile)
'cl-byte-compile-compiler-macro)
(functionp 'compiler-macroexpand))))
. ,_)
(let ((newform (with-no-warnings (compiler-macroexpand form))))
(if (eq form newform)
(macroexpand-all-forms form 1)
(macroexpand-all-1 newform))))
(`(,_ . ,_)
;; For every other list, we just expand each argument (for
;; setq/setq-default this works alright because the variable names

205
lisp/emacs-lisp/pcase.el
View File

@ -1,4 +1,4 @@
;;; pcase.el --- ML-style pattern-matching macro for Elisp
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
@ -27,16 +27,21 @@
;; Todo:
;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
;; use x, because x is bound separately for the equality constraint
;; (as well as any pred/guard) and for the body, so uses at one place don't
;; count for the other.
;; - provide ways to extend the set of primitives, with some kind of
;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
;; But better would be if we could define new ways to match by having the
;; extension provide its own `pcase--split-<foo>' thingy.
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
;; - provide a way to fallthrough to other cases.
;; - provide a way to fallthrough to subsequent cases.
;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leafs that need to be turned into function:
;; to reduce the number of leaves that need to be turned into function:
;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better so it first so it's shared).
;; - then choose the test that discriminates more (?).
@ -45,14 +50,12 @@
;;; Code:
(eval-when-compile (require 'cl))
;; Macro-expansion of pcase is reasonably fast, so it's not a problem
;; when byte-compiling a file, but when interpreting the code, if the pcase
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
(defconst pcase--dontcare-upats '(t _ dontcare))
@ -69,6 +72,7 @@ UPatterns can take the following forms:
`QPAT matches if the QPattern QPAT matches.
(pred PRED) matches if PRED applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let UPAT EXP) matches if EXP matches UPAT.
If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
@ -88,10 +92,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
(declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
(or (gethash (cons exp cases) pcase-memoize)
(puthash (cons exp cases)
(pcase--expand exp cases)
pcase-memoize)))
;; We want to use a weak hash table as a cache, but the key will unavoidably
;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
;; we're called so it'll be immediately GC'd. So we use (car cases) as key
;; which does come straight from the source code and should hence not be GC'd
;; so easily.
(let ((data (gethash (car cases) pcase--memoize)))
;; data = (EXP CASES . EXPANSION)
(if (and (equal exp (car data)) (equal cases (cadr data)))
;; We have the right expansion.
(cddr data)
(when data
(message "pcase-memoize: equal first branch, yet different"))
(let ((expansion (pcase--expand exp cases)))
(puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
expansion))))
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
@ -145,6 +160,8 @@ of the form (UPAT EXP)."
(and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(let* ((defs (if (symbolp exp) '()
(let ((sym (make-symbol "x")))
(prog1 `((,sym ,exp)) (setq exp sym)))))
@ -165,7 +182,9 @@ of the form (UPAT EXP)."
;; to a separate function if that number is too high.
;;
;; We've already used this branch. So it is shared.
(destructuring-bind (code prevvars res) prev
(let* ((code (car prev)) (cdrprev (cdr prev))
(prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
(res (car cddrprev)))
(unless (symbolp res)
;; This is the first repeat, so we have to move
;; the branch to a separate function.
@ -269,7 +288,10 @@ MATCH is the pattern that needs to be matched, of the form:
(and MATCH ...)
(or MATCH ...)"
(when (setq branches (delq nil branches))
(destructuring-bind (match code &rest vars) (car branches)
(let* ((carbranch (car branches))
(match (car carbranch)) (cdarbranch (cdr carbranch))
(code (car cdarbranch))
(vars (cdr cdarbranch)))
(pcase--u1 (list match) code vars (cdr branches)))))
(defun pcase--and (match matches)
@ -281,19 +303,25 @@ MATCH is the pattern that needs to be matched, of the form:
(symbolp . consp)
(symbolp . arrayp)
(symbolp . stringp)
(symbolp . byte-code-function-p)
(integerp . consp)
(integerp . arrayp)
(integerp . stringp)
(integerp . byte-code-function-p)
(numberp . consp)
(numberp . arrayp)
(numberp . stringp)
(numberp . byte-code-function-p)
(consp . arrayp)
(consp . stringp)
(arrayp . stringp)))
(consp . byte-code-function-p)
(arrayp . stringp)
(arrayp . byte-code-function-p)
(stringp . byte-code-function-p)))
(defun pcase--split-match (sym splitter match)
(case (car match)
((match)
(cond
((eq (car match) 'match)
(if (not (eq sym (cadr match)))
(cons match match)
(let ((pat (cddr match)))
@ -307,7 +335,7 @@ MATCH is the pattern that needs to be matched, of the form:
(cdr pat)))))
(t (let ((res (funcall splitter (cddr match))))
(cons (or (car res) match) (or (cdr res) match))))))))
((or and)
((memq (car match) '(or and))
(let ((then-alts '())
(else-alts '())
(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
(pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
code vars
(if (null others) rest
(cons (list*
(cons (cons
(pcase--and (if (cdr others)
(cons 'or (nreverse others))
(car others))
(cdr matches))
code vars)
(cons code vars))
rest))))
(t
(pcase--u1 (cons (pop alts) (cdr matches)) code vars
(if (null alts) (progn (error "Please avoid it") rest)
(cons (list*
(cons (cons
(pcase--and (if (cdr alts)
(cons 'or alts) (car alts))
(cdr matches))
code vars)
(cons code vars))
rest)))))))
((eq 'match (caar matches))
(destructuring-bind (op sym &rest upat) (pop matches)
(let* ((popmatches (pop matches))
(_op (car popmatches)) (cdrpopmatches (cdr popmatches))
(sym (car cdrpopmatches))
(upat (cdr cdrpopmatches)))
(cond
((memq upat '(t _)) (pcase--u1 matches code vars rest))
((eq upat 'dontcare) :pcase--dontcare)
((functionp upat) (error "Feature removed, use (pred %s)" upat))
((memq (car-safe upat) '(guard pred))
(if (eq (car upat) 'pred) (put sym 'pcase-used t))
(destructuring-bind (then-rest &rest else-rest)
(pcase--split-rest
sym (apply-partially #'pcase--split-pred upat) rest)
(let* ((splitrest
(pcase--split-rest
sym (apply-partially #'pcase--split-pred upat) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
`(,(cadr upat) ,sym)
(let* ((exp (cadr upat))
;; `vs' is an upper bound on the vars we need.
(vs (pcase--fgrep (mapcar #'car vars) exp))
(call (cond
((eq 'guard (car upat)) exp)
((functionp exp) `(,exp ,sym))
(t `(,@exp ,sym)))))
(env (mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs))
(call (if (eq 'guard (car upat))
exp
(when (memq sym vs)
;; `sym' is shadowed by `env'.
(let ((newsym (make-symbol "x")))
(push (list newsym sym) env)
(setq sym newsym)))
(if (functionp exp) `(,exp ,sym)
`(,@exp ,sym)))))
(if (null vs)
call
;; Let's not replace `vars' in `exp' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `exp'.
`(let ,(mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs)
;; FIXME: `vars' can capture `sym'. E.g.
;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
,call))))
`(let* ,env ,call))))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((symbolp upat)
@ -531,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form
(pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
matches)
code vars rest)))
((eq (car-safe upat) 'let)
;; A upat of the form (let VAR EXP).
;; (pcase--u1 matches code
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(let* ((exp
(let* ((exp (nth 2 upat))
(found (assq exp vars)))
(if found (cdr found)
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs)))
(if env `(let* ,env ,exp) exp)))))
(sym (if (symbolp exp) exp (make-symbol "x")))
(body
(pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
code vars rest)))
(if (eq sym exp)
body
`(let* ((,sym ,exp)) ,body))))
((eq (car-safe upat) '\`)
(put sym 'pcase-used t)
(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
(setq all nil))))
(if all
;; Use memq for (or `a `b `c `d) rather than a big tree.
(let ((elems (mapcar 'cadr (cdr upat))))
(destructuring-bind (then-rest &rest else-rest)
(pcase--split-rest
sym (apply-partially #'pcase--split-member elems) rest)
(pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
(let* ((elems (mapcar 'cadr (cdr upat)))
(splitrest
(pcase--split-rest
sym (apply-partially #'pcase--split-member elems) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest)))
(pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
(append (mapcar (lambda (upat)
`((and (match ,sym . ,upat) ,@matches)
@ -575,15 +631,14 @@ Otherwise, it defers to REST which is a list of branches of the form
;; `(PAT3 . PAT4)) which the programmer can easily rewrite
;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
(pcase--u1 `((match ,sym . ,(cadr upat)))
(lexical-let ((rest rest))
;; FIXME: This codegen is not careful to share its
;; code if used several times: code blow up is likely.
(lambda (vars)
;; `vars' will likely contain bindings which are
;; not always available in other paths to
;; `rest', so there' no point trying to pass
;; them down.
(pcase--u rest)))
;; FIXME: This codegen is not careful to share its
;; code if used several times: code blow up is likely.
(lambda (_vars)
;; `vars' will likely contain bindings which are
;; not always available in other paths to
;; `rest', so there' no point trying to pass
;; them down.
(pcase--u rest))
vars
(list `((and . ,matches) ,code . ,vars))))
(t (error "Unknown upattern `%s'" upat)))))
@ -600,29 +655,33 @@ Otherwise, it defers to REST which is a list of branches of the form
;; FIXME.
(error "Vector QPatterns not implemented yet"))
((consp qpat)
(let ((syma (make-symbol "xcar"))
(symd (make-symbol "xcdr")))
(destructuring-bind (then-rest &rest else-rest)
(pcase--split-rest sym
(apply-partially #'pcase--split-consp syma symd)
rest)
(let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
(match ,symd . ,(pcase--upat (cdr qpat)))
,@matches)
code vars then-rest)))
(pcase--if
`(consp ,sym)
;; We want to be careful to only add bindings that are used.
;; The byte-compiler could do that for us, but it would have to pay
;; attention to the `consp' test in order to figure out that car/cdr
;; can't signal errors and our byte-compiler is not that clever.
`(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
,then-body)
(pcase--u else-rest))))))
(let* ((syma (make-symbol "xcar"))
(symd (make-symbol "xcdr"))
(splitrest (pcase--split-rest
sym
(apply-partially #'pcase--split-consp syma symd)
rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest))
(then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
(match ,symd . ,(pcase--upat (cdr qpat)))
,@matches)
code vars then-rest)))
(pcase--if
`(consp ,sym)
;; We want to be careful to only add bindings that are used.
;; The byte-compiler could do that for us, but it would have to pay
;; attention to the `consp' test in order to figure out that car/cdr
;; can't signal errors and our byte-compiler is not that clever.
`(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
,then-body)
(pcase--u else-rest))))
((or (integerp qpat) (symbolp qpat) (stringp qpat))
(destructuring-bind (then-rest &rest else-rest)
(pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)
(let* ((splitrest (pcase--split-rest
sym (apply-partially 'pcase--split-equal qpat) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))

4
lisp/emacs-lisp/smie.el
View File

@ -1,4 +1,4 @@
;;; smie.el --- Simple Minded Indentation Engine
;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*-
;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
@ -178,7 +178,7 @@ one of those elements share the same precedence level and associativity."
;; Maybe also add (or <elem1> <elem2>...) for things like
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
;; the repetition).
;; the repetition, maybe).
(let ((nts (mapcar 'car bnf)) ;Non-terminals
(first-ops-table ())
(last-ops-table ())

25
lisp/files.el
View File

@ -2869,18 +2869,19 @@ asking you for confirmation."
;;
;; For variables defined in the C source code the declaration should go here:
(mapc (lambda (pair)
(put (car pair) 'safe-local-variable (cdr pair)))
'((buffer-read-only . booleanp) ;; C source code
(default-directory . stringp) ;; C source code
(fill-column . integerp) ;; C source code
(indent-tabs-mode . booleanp) ;; C source code
(left-margin . integerp) ;; C source code
(no-update-autoloads . booleanp)
(tab-width . integerp) ;; C source code
(truncate-lines . booleanp) ;; C source code
(word-wrap . booleanp) ;; C source code
(bidi-display-reordering . booleanp))) ;; C source code
(dolist (pair
'((buffer-read-only . booleanp) ;; C source code
(default-directory . stringp) ;; C source code
(fill-column . integerp) ;; C source code
(indent-tabs-mode . booleanp) ;; C source code
(left-margin . integerp) ;; C source code
(no-update-autoloads . booleanp)
(lexical-binding . booleanp) ;; C source code
(tab-width . integerp) ;; C source code
(truncate-lines . booleanp) ;; C source code
(word-wrap . booleanp) ;; C source code
(bidi-display-reordering . booleanp))) ;; C source code
(put (car pair) 'safe-local-variable (cdr pair)))
(put 'bidi-paragraph-direction 'safe-local-variable
(lambda (v) (memq v '(nil right-to-left left-to-right))))

3
lisp/follow.el
View File

@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)"
;; XEmacs can calculate the end of the window by using
;; the 'guarantee options. GOOD!
(let ((end (window-end win t)))
(if (= end (funcall (symbol-function 'point-max)
(window-buffer win)))
(if (= end (point-max (window-buffer win)))
(list end t)
(list (+ end 1) nil)))
;; Emacs: We have to calculate the end by ourselves.

64
lisp/help-fns.el
View File

@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING."
;; Replace `fn' with the actual function name.
(if (consp def) "anonymous" def)
(match-string 1 docstring))
(substring docstring 0 (match-beginning 0)))))
(unless (zerop (match-beginning 0))
(substring docstring 0 (match-beginning 0))))))
;; FIXME: Move to subr.el?
(defun help-add-fundoc-usage (docstring arglist)
"Add the usage info to DOCSTRING.
If DOCSTRING already has a usage info, then just return it unchanged.
The usage info is built from ARGLIST. DOCSTRING can be nil.
ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(unless (stringp docstring) (setq docstring "Not documented"))
(if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
(unless (stringp docstring) (setq docstring ""))
(if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
(eq arglist t))
docstring
(concat docstring
(if (string-match "\n?\n\\'" docstring)
@ -95,18 +98,52 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(concat "(fn" (match-string 1 arglist) ")")
(format "%S" (help-make-usage 'fn arglist))))))
;; FIXME: Move to subr.el?
(defun help-function-arglist (def)
;; Handle symbols aliased to other symbols.
(if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
;; If definition is a macro, find the function inside it.
(if (eq (car-safe def) 'macro) (setq def (cdr def)))
(cond
((and (byte-code-function-p def) (integerp (aref def 0)))
(let* ((args-desc (aref def 0))
(max (lsh args-desc -8))
(min (logand args-desc 127))
(rest (logand args-desc 128))
(arglist ()))
(dotimes (i min)
(push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
(when (> max min)
(push '&optional arglist)
(dotimes (i (- max min))
(push (intern (concat "arg" (number-to-string (+ 1 i min))))
arglist)))
(unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
(nreverse arglist)))
((byte-code-function-p def) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
((eq (car-safe def) 'closure) (nth 2 def))
((subrp def)
(let ((arity (subr-arity def))
(arglist ()))
(dotimes (i (car arity))
(push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
(cond
((not (numberp (cdr arglist)))
(push '&rest arglist)
(push 'rest arglist))
((< (car arity) (cdr arity))
(push '&optional arglist)
(dotimes (i (- (cdr arity) (car arity)))
(push (intern (concat "arg" (number-to-string
(+ 1 i (car arity)))))
arglist))))
(nreverse arglist)))
((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
(t t)))
;; FIXME: Move to subr.el?
(defun help-make-usage (function arglist)
(cons (if (symbolp function) function 'anonymous)
(mapcar (lambda (arg)
@ -117,8 +154,11 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(cdr arg))
arg)
(let ((name (symbol-name arg)))
(if (string-match "\\`&" name) arg
(intern (upcase name))))))
(cond
((string-match "\\`&" name) arg)
((string-match "\\`_" name)
(intern (upcase (substring name 1))))
(t (intern (upcase name)))))))
arglist)))
;; 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."
doc t t 1)))))
(defun help-highlight-arguments (usage doc &rest args)
(when usage
(when (and usage (string-match "^(" usage))
(with-temp-buffer
(insert usage)
(goto-char (point-min))
@ -353,8 +393,7 @@ suitable file is found, return nil."
(pt1 (with-current-buffer (help-buffer) (point)))
errtype)
(setq string
(cond ((or (stringp def)
(vectorp def))
(cond ((or (stringp def) (vectorp def))
"a keyboard macro")
((subrp def)
(if (eq 'unevalled (cdr (subr-arity def)))
@ -373,6 +412,8 @@ suitable file is found, return nil."
(concat beg "Lisp function"))
((eq (car-safe def) 'macro)
"a Lisp macro")
((eq (car-safe def) 'closure)
(concat beg "Lisp closure"))
((eq (car-safe def) 'autoload)
(format "%s autoloaded %s"
(if (commandp def) "an interactive" "an")
@ -593,10 +634,9 @@ it is displayed along with the global value."
"Describe variable (default %s): " v)
"Describe variable: ")
obarray
(lambda (vv)
(and (not (keywordp vv))
(or (boundp vv)
(get vv 'variable-documentation))))
(lambda (vv)
(or (special-variable-p vv)
(get vv 'variable-documentation)))
t nil nil
(if (symbolp v) (symbol-name v))))
(list (if (equal val "")

3
lisp/ielm.el
View File

@ -371,7 +371,8 @@ simply inserts a newline."
(*** *3))
(kill-buffer (current-buffer))
(set-buffer ielm-wbuf)
(setq ielm-result (eval ielm-form))
(setq ielm-result
(eval ielm-form lexical-binding))
(setq ielm-wbuf (current-buffer))
(setq
ielm-temp-buffer

33
lisp/makefile.w32-in
View File

@ -66,6 +66,15 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
$(lisp)/cedet/semantic/loaddefs.el $(lisp)/cedet/ede/loaddefs.el \
$(lisp)/cedet/srecode/loaddefs.el
# Value of max-lisp-eval-depth when compiling initially.
# During bootstrapping the byte-compiler is run interpreted when compiling
# itself, and uses more stack than usual.
#
BIG_STACK_DEPTH = 1200
BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
BYTE_COMPILE_FLAGS = $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS)
# Files to compile before others during a bootstrap. This is done to
# speed up the bootstrap process. The CC files are compiled first
# because CC mode tweaks the compilation process, and requiring
@ -75,6 +84,8 @@ AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
COMPILE_FIRST = \
$(lisp)/emacs-lisp/byte-opt.el \
$(lisp)/emacs-lisp/bytecomp.el \
$(lisp)/emacs-lisp/macroexp.el \
$(lisp)/emacs-lisp/cconv.el \
$(lisp)/subr.el \
$(lisp)/progmodes/cc-mode.el \
$(lisp)/progmodes/cc-vars.el
@ -287,7 +298,7 @@ TAGS-LISP-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsf
.SUFFIXES: .elc .el
.el.elc:
-$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $<
-$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
# Compile all Lisp files, but don't recompile those that are up to
# date. Some files don't actually get compiled because they set the
@ -307,22 +318,22 @@ compile: $(lisp)/subdirs.el mh-autoloads compile-$(SHELLTYPE) doit
compile-CMD:
# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
for %%f in ($(COMPILE_FIRST)) do \
$(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f
$(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f
for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \
$(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g
$(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done %%f/%%g
compile-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
for el in $(COMPILE_FIRST); do \
echo Compiling $$el; \
$(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \
$(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
done
for dir in $(lisp) $(WINS); do \
for el in $$dir/*.el; do \
if test -f $$el; \
then \
echo Compiling $$el; \
$(emacs) -l loaddefs $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el; \
$(emacs) -l loaddefs $(BYTE_COMPILE_FLAGS) -f batch-byte-compile-if-not-done $$el; \
fi \
done; \
done
@ -335,31 +346,31 @@ compile-always: $(lisp)/subdirs.el compile-always-$(SHELLTYPE) doit
compile-always-CMD:
# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f
for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f/%%g
for %%f in ($(COMPILE_FIRST)) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f/%%g
compile-always-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
for el in $(COMPILE_FIRST); do \
echo Compiling $$el; \
$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done
for dir in $(lisp) $(WINS); do \
for el in $$dir/*.el; do \
echo Compiling $$el; \
$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done; \
done
compile-calc: compile-calc-$(SHELLTYPE)
compile-calc-CMD:
for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile %%f
for %%f in ($(lisp)/calc/*.el) do $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile %%f
compile-calc-SH:
for el in $(lisp)/calc/*.el; do \
echo Compiling $$el; \
$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \
done
# Backup compiled Lisp files in elc.tar.gz. If that file already

552
lisp/minibuffer.el
View File

@ -1,4 +1,4 @@
;;; minibuffer.el --- Minibuffer completion functions
;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
@ -133,8 +133,8 @@ the closest directory separators."
"Apply FUN to each element of XS in turn.
Return the first non-nil returned value.
Like CL's `some'."
(lexical-let ((firsterror nil)
res)
(let ((firsterror nil)
res)
(while (and (not res) xs)
(condition-case err
(setq res (funcall fun (pop xs)))
@ -171,16 +171,15 @@ FUN will be called in the buffer from which the minibuffer was entered.
The result of the `completion-table-dynamic' form is a function
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
(lexical-let ((fun fun))
(lambda (string pred action)
(if (eq (car-safe action) 'boundaries)
;; `fun' is not supposed to return another function but a plain old
;; completion table, whose boundaries are always trivial.
nil
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
(complete-with-action action (funcall fun string) string pred))))))
(lambda (string pred action)
(if (eq (car-safe action) 'boundaries)
;; `fun' is not supposed to return another function but a plain old
;; completion table, whose boundaries are always trivial.
nil
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
(complete-with-action action (funcall fun string) string pred)))))
(defmacro lazy-completion-table (var fun)
"Initialize variable VAR as a lazy completion table.
@ -209,19 +208,18 @@ You should give VAR a non-nil `risky-local-variable' property."
;; Notice that `pred' may not be a function in some abusive cases.
(when (functionp pred)
(setq pred
(lexical-let ((pred pred))
;; Predicates are called differently depending on the nature of
;; the completion table :-(
(cond
((vectorp table) ;Obarray.
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
((hash-table-p table)
(lambda (s v) (funcall pred (concat prefix s))))
((functionp table)
(lambda (s) (funcall pred (concat prefix s))))
(t ;Lists and alists.
(lambda (s)
(funcall pred (concat prefix (if (consp s) (car s) s)))))))))
;; Predicates are called differently depending on the nature of
;; the completion table :-(
(cond
((vectorp table) ;Obarray.
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
((hash-table-p table)
(lambda (s _v) (funcall pred (concat prefix s))))
((functionp table)
(lambda (s) (funcall pred (concat prefix s))))
(t ;Lists and alists.
(lambda (s)
(funcall pred (concat prefix (if (consp s) (car s) s))))))))
(if (eq (car-safe action) 'boundaries)
(let* ((len (length prefix))
(bound (completion-boundaries string table pred (cdr action))))
@ -300,11 +298,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
(t
(or (complete-with-action action table string
(if (null pred2) pred1
(lexical-let ((pred1 pred2) (pred2 pred2))
(lambda (x)
;; Call `pred1' first, so that `pred2'
;; really can't tell that `x' is in table.
(if (funcall pred1 x) (funcall pred2 x))))))
(lambda (x)
;; Call `pred1' first, so that `pred2'
;; really can't tell that `x' is in table.
(if (funcall pred1 x) (funcall pred2 x)))))
;; If completion failed and we're not applying pred1 strictly, try
;; again without pred1.
(and (not strict)
@ -314,11 +311,10 @@ Note: TABLE needs to be a proper completion table which obeys predicates."
"Create a completion table that tries each table in TABLES in turn."
;; FIXME: the boundaries may come from TABLE1 even when the completion list
;; is returned by TABLE2 (because TABLE1 returned an empty list).
(lexical-let ((tables tables))
(lambda (string pred action)
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables))))
(lambda (string pred action)
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables)))
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
@ -560,16 +556,15 @@ E = after completion we now have an Exact match.
101 5 ??? impossible
110 6 some completion happened
111 7 completed to an exact completion"
(lexical-let*
((beg (field-beginning))
(end (field-end))
(string (buffer-substring beg end))
(comp (funcall (or try-completion-function
'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) beg))))
(let* ((beg (field-beginning))
(end (field-end))
(string (buffer-substring beg end))
(comp (funcall (or try-completion-function
'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) beg))))
(cond
((null comp)
(minibuffer-hide-completions)
@ -584,13 +579,12 @@ E = after completion we now have an Exact match.
;; `completed' should be t if some completion was done, which doesn't
;; include simply changing the case of the entered string. However,
;; for appearance, the string is rewritten if the case changes.
(lexical-let*
((comp-pos (cdr comp))
(completion (car comp))
(completed (not (eq t (compare-strings completion nil nil
string nil nil t))))
(unchanged (eq t (compare-strings completion nil nil
string nil nil nil))))
(let* ((comp-pos (cdr comp))
(completion (car comp))
(completed (not (eq t (compare-strings completion nil nil
string nil nil t))))
(unchanged (eq t (compare-strings completion nil nil
string nil nil nil))))
(if unchanged
(goto-char end)
;; Insert in minibuffer the chars we got.
@ -672,16 +666,16 @@ scroll the window of possible completions."
(setq minibuffer-scroll-window nil))
(cond
;; If there's a fresh completion window with a live buffer,
;; and this command is repeated, scroll that window.
;; If there's a fresh completion window with a live buffer,
;; and this command is repeated, scroll that window.
((window-live-p minibuffer-scroll-window)
(let ((window minibuffer-scroll-window))
(with-current-buffer (window-buffer window)
(if (pos-visible-in-window-p (point-max) window)
;; If end is in view, scroll up to the beginning.
(set-window-start window (point-min) nil)
;; Else scroll down one screen.
(scroll-other-window))
(with-current-buffer (window-buffer window)
(if (pos-visible-in-window-p (point-max) window)
;; If end is in view, scroll up to the beginning.
(set-window-start window (point-min) nil)
;; Else scroll down one screen.
(scroll-other-window))
nil)))
;; If we're cycling, keep on cycling.
((and completion-cycling completion-all-sorted-completions)
@ -695,7 +689,7 @@ scroll the window of possible completions."
t)
(t t)))))
(defun completion--flush-all-sorted-completions (&rest ignore)
(defun completion--flush-all-sorted-completions (&rest _ignore)
(remove-hook 'after-change-functions
'completion--flush-all-sorted-completions t)
(setq completion-cycling nil)
@ -783,8 +777,8 @@ If `minibuffer-completion-confirm' is `confirm-after-completion',
`minibuffer-confirm-exit-commands', and accept the input
otherwise."
(interactive)
(lexical-let ((beg (field-beginning))
(end (field-end)))
(let ((beg (field-beginning))
(end (field-end)))
(cond
;; Allow user to specify null string
((= beg end) (exit-minibuffer))
@ -1029,7 +1023,7 @@ It also eliminates runs of equal strings."
'mouse-face 'highlight)
(add-text-properties (point) (progn (insert (cadr str)) (point))
'(mouse-face nil
face completions-annotations)))
face completions-annotations)))
(cond
((eq completions-format 'vertical)
;; Vertical format
@ -1161,14 +1155,14 @@ variables.")
"Display a list of possible completions of the current minibuffer contents."
(interactive)
(message "Making completion list...")
(lexical-let* ((start (field-beginning))
(end (field-end))
(string (field-string))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) (field-beginning)))))
(let* ((start (field-beginning))
(end (field-end))
(string (field-string))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
(- (point) (field-beginning)))))
(message nil)
(if (and completions
(or (consp (cdr completions))
@ -1462,7 +1456,7 @@ The completion method is determined by `completion-at-point-functions'."
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
"$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
(defun completion--embedded-envvar-table (string pred action)
(defun completion--embedded-envvar-table (string _pred action)
"Completion table for envvars embedded in a string.
The envvar syntax (and escaping) rules followed by this table are the
same as `substitute-in-file-name'."
@ -1482,20 +1476,20 @@ same as `substitute-in-file-name'."
;; other table handle the test-completion case.
nil)
((eq (car-safe action) 'boundaries)
;; Only return boundaries if there's something to complete,
;; since otherwise when we're used in
;; completion-table-in-turn, we could return boundaries and
;; let some subsequent table return a list of completions.
;; FIXME: Maybe it should rather be fixed in
;; completion-table-in-turn instead, but it's difficult to
;; do it efficiently there.
;; Only return boundaries if there's something to complete,
;; since otherwise when we're used in
;; completion-table-in-turn, we could return boundaries and
;; let some subsequent table return a list of completions.
;; FIXME: Maybe it should rather be fixed in
;; completion-table-in-turn instead, but it's difficult to
;; do it efficiently there.
(when (try-completion (substring string beg) table nil)
;; Compute the boundaries of the subfield to which this
;; completion applies.
(let ((suffix (cdr action)))
(list* 'boundaries
(or (match-beginning 2) (match-beginning 1))
(when (string-match "[^[:alnum:]_]" suffix)
;; Compute the boundaries of the subfield to which this
;; completion applies.
(let ((suffix (cdr action)))
(list* 'boundaries
(or (match-beginning 2) (match-beginning 1))
(when (string-match "[^[:alnum:]_]" suffix)
(match-beginning 0))))))
(t
(if (eq (aref string (1- beg)) ?{)
@ -1510,55 +1504,55 @@ same as `substitute-in-file-name'."
(defun completion-file-name-table (string pred action)
"Completion table for file names."
(ignore-errors
(cond
((eq (car-safe action) 'boundaries)
(let ((start (length (file-name-directory string)))
(end (string-match-p "/" (cdr action))))
(list* 'boundaries
;; if `string' is "C:" in w32, (file-name-directory string)
;; returns "C:/", so `start' is 3 rather than 2.
;; Not quite sure what is The Right Fix, but clipping it
;; back to 2 will work for this particular case. We'll
;; see if we can come up with a better fix when we bump
;; into more such problematic cases.
(min start (length string)) end)))
(cond
((eq (car-safe action) 'boundaries)
(let ((start (length (file-name-directory string)))
(end (string-match-p "/" (cdr action))))
(list* 'boundaries
;; if `string' is "C:" in w32, (file-name-directory string)
;; returns "C:/", so `start' is 3 rather than 2.
;; Not quite sure what is The Right Fix, but clipping it
;; back to 2 will work for this particular case. We'll
;; see if we can come up with a better fix when we bump
;; into more such problematic cases.
(min start (length string)) end)))
((eq action 'lambda)
(if (zerop (length string))
nil ;Not sure why it's here, but it probably doesn't harm.
(funcall (or pred 'file-exists-p) string)))
((eq action 'lambda)
(if (zerop (length string))
nil ;Not sure why it's here, but it probably doesn't harm.
(funcall (or pred 'file-exists-p) string)))
(t
(t
(let* ((name (file-name-nondirectory string))
(specdir (file-name-directory string))
(realdir (or specdir default-directory)))
(cond
((null action)
(cond
((null action)
(let ((comp (file-name-completion name realdir pred)))
(if (stringp comp)
(concat specdir comp)
comp)))
((eq action t)
(let ((all (file-name-all-completions name realdir)))
((eq action t)
(let ((all (file-name-all-completions name realdir)))
;; Check the predicate, if necessary.
;; Check the predicate, if necessary.
(unless (memq pred '(nil file-exists-p))
(let ((comp ())
(pred
(let ((comp ())
(pred
(if (eq pred 'file-directory-p)
;; Brute-force speed up for directory checking:
;; Discard strings which don't end in a slash.
(lambda (s)
(let ((len (length s)))
(and (> len 0) (eq (aref s (1- len)) ?/))))
;; Must do it the hard (and slow) way.
;; Brute-force speed up for directory checking:
;; Discard strings which don't end in a slash.
(lambda (s)
(let ((len (length s)))
(and (> len 0) (eq (aref s (1- len)) ?/))))
;; Must do it the hard (and slow) way.
pred)))
(let ((default-directory (expand-file-name realdir)))
(dolist (tem all)
(if (funcall pred tem) (push tem comp))))
(setq all (nreverse comp))))
(dolist (tem all)
(if (funcall pred tem) (push tem comp))))
(setq all (nreverse comp))))
all))))))))
@ -1755,122 +1749,122 @@ See `read-file-name' for the meaning of the arguments."
(minibuffer--double-dollars dir)))
(initial (cons (minibuffer--double-dollars initial) 0)))))
(let ((completion-ignore-case read-file-name-completion-ignore-case)
(minibuffer-completing-file-name t)
(pred (or predicate 'file-exists-p))
(add-to-history nil))
(let ((completion-ignore-case read-file-name-completion-ignore-case)
(minibuffer-completing-file-name t)
(pred (or predicate 'file-exists-p))
(add-to-history nil))
(let* ((val
(if (or (not (next-read-file-uses-dialog-p))
;; Graphical file dialogs can't handle remote
;; files (Bug#99).
(file-remote-p dir))
;; We used to pass `dir' to `read-file-name-internal' by
;; abusing the `predicate' argument. It's better to
;; just use `default-directory', but in order to avoid
;; changing `default-directory' in the current buffer,
;; we don't let-bind it.
(lexical-let ((dir (file-name-as-directory
(expand-file-name dir))))
(minibuffer-with-setup-hook
(lambda ()
(setq default-directory dir)
;; When the first default in `minibuffer-default'
;; duplicates initial input `insdef',
;; reset `minibuffer-default' to nil.
(when (equal (or (car-safe insdef) insdef)
(or (car-safe minibuffer-default)
minibuffer-default))
(setq minibuffer-default
(cdr-safe minibuffer-default)))
;; On the first request on `M-n' fill
;; `minibuffer-default' with a list of defaults
;; relevant for file-name reading.
(set (make-local-variable 'minibuffer-default-add-function)
(lambda ()
(with-current-buffer
(window-buffer (minibuffer-selected-window))
(let* ((val
(if (or (not (next-read-file-uses-dialog-p))
;; Graphical file dialogs can't handle remote
;; files (Bug#99).
(file-remote-p dir))
;; We used to pass `dir' to `read-file-name-internal' by
;; abusing the `predicate' argument. It's better to
;; just use `default-directory', but in order to avoid
;; changing `default-directory' in the current buffer,
;; we don't let-bind it.
(let ((dir (file-name-as-directory
(expand-file-name dir))))
(minibuffer-with-setup-hook
(lambda ()
(setq default-directory dir)
;; When the first default in `minibuffer-default'
;; duplicates initial input `insdef',
;; reset `minibuffer-default' to nil.
(when (equal (or (car-safe insdef) insdef)
(or (car-safe minibuffer-default)
minibuffer-default))
(setq minibuffer-default
(cdr-safe minibuffer-default)))
;; On the first request on `M-n' fill
;; `minibuffer-default' with a list of defaults
;; relevant for file-name reading.
(set (make-local-variable 'minibuffer-default-add-function)
(lambda ()
(with-current-buffer
(window-buffer (minibuffer-selected-window))
(read-file-name--defaults dir initial)))))
(completing-read prompt 'read-file-name-internal
pred mustmatch insdef
'file-name-history default-filename)))
;; If DEFAULT-FILENAME not supplied and DIR contains
;; a file name, split it.
(let ((file (file-name-nondirectory dir))
;; When using a dialog, revert to nil and non-nil
;; interpretation of mustmatch. confirm options
;; need to be interpreted as nil, otherwise
;; it is impossible to create new files using
;; dialogs with the default settings.
(dialog-mustmatch
(not (memq mustmatch
'(nil confirm confirm-after-completion)))))
(when (and (not default-filename)
(not (zerop (length file))))
(setq default-filename file)
(setq dir (file-name-directory dir)))
(when default-filename
(setq default-filename
(expand-file-name (if (consp default-filename)
(car default-filename)
default-filename)
dir)))
(setq add-to-history t)
(x-file-dialog prompt dir default-filename
dialog-mustmatch
(eq predicate 'file-directory-p)))))
(completing-read prompt 'read-file-name-internal
pred mustmatch insdef
'file-name-history default-filename)))
;; If DEFAULT-FILENAME not supplied and DIR contains
;; a file name, split it.
(let ((file (file-name-nondirectory dir))
;; When using a dialog, revert to nil and non-nil
;; interpretation of mustmatch. confirm options
;; need to be interpreted as nil, otherwise
;; it is impossible to create new files using
;; dialogs with the default settings.
(dialog-mustmatch
(not (memq mustmatch
'(nil confirm confirm-after-completion)))))
(when (and (not default-filename)
(not (zerop (length file))))
(setq default-filename file)
(setq dir (file-name-directory dir)))
(when default-filename
(setq default-filename
(expand-file-name (if (consp default-filename)
(car default-filename)
default-filename)
dir)))
(setq add-to-history t)
(x-file-dialog prompt dir default-filename
dialog-mustmatch
(eq predicate 'file-directory-p)))))
(replace-in-history (eq (car-safe file-name-history) val)))
;; If completing-read returned the inserted default string itself
;; (rather than a new string with the same contents),
;; it has to mean that the user typed RET with the minibuffer empty.
;; In that case, we really want to return ""
;; so that commands such as set-visited-file-name can distinguish.
(when (consp default-filename)
(setq default-filename (car default-filename)))
(when (eq val default-filename)
;; In this case, completing-read has not added an element
;; to the history. Maybe we should.
(if (not replace-in-history)
(setq add-to-history t))
(setq val ""))
(unless val (error "No file name specified"))
(replace-in-history (eq (car-safe file-name-history) val)))
;; If completing-read returned the inserted default string itself
;; (rather than a new string with the same contents),
;; it has to mean that the user typed RET with the minibuffer empty.
;; In that case, we really want to return ""
;; so that commands such as set-visited-file-name can distinguish.
(when (consp default-filename)
(setq default-filename (car default-filename)))
(when (eq val default-filename)
;; In this case, completing-read has not added an element
;; to the history. Maybe we should.
(if (not replace-in-history)
(setq add-to-history t))
(setq val ""))
(unless val (error "No file name specified"))
(if (and default-filename
(string-equal val (if (consp insdef) (car insdef) insdef)))
(setq val default-filename))
(setq val (substitute-in-file-name val))
(if (and default-filename
(string-equal val (if (consp insdef) (car insdef) insdef)))
(setq val default-filename))
(setq val (substitute-in-file-name val))
(if replace-in-history
;; Replace what Fcompleting_read added to the history
;; with what we will actually return. As an exception,
;; if that's the same as the second item in
;; file-name-history, it's really a repeat (Bug#4657).
(if replace-in-history
;; Replace what Fcompleting_read added to the history
;; with what we will actually return. As an exception,
;; if that's the same as the second item in
;; file-name-history, it's really a repeat (Bug#4657).
(let ((val1 (minibuffer--double-dollars val)))
(if history-delete-duplicates
(setcdr file-name-history
(delete val1 (cdr file-name-history))))
(if (string= val1 (cadr file-name-history))
(pop file-name-history)
(setcar file-name-history val1)))
(if add-to-history
;; Add the value to the history--but not if it matches
;; the last value already there.
(let ((val1 (minibuffer--double-dollars val)))
(if history-delete-duplicates
(setcdr file-name-history
(delete val1 (cdr file-name-history))))
(if (string= val1 (cadr file-name-history))
(pop file-name-history)
(setcar file-name-history val1)))
(if add-to-history
;; Add the value to the history--but not if it matches
;; the last value already there.
(let ((val1 (minibuffer--double-dollars val)))
(unless (and (consp file-name-history)
(equal (car file-name-history) val1))
(setq file-name-history
(cons val1
(if history-delete-duplicates
(delete val1 file-name-history)
file-name-history)))))))
(unless (and (consp file-name-history)
(equal (car file-name-history) val1))
(setq file-name-history
(cons val1
(if history-delete-duplicates
(delete val1 file-name-history)
file-name-history)))))))
val))))
(defun internal-complete-buffer-except (&optional buffer)
"Perform completion on all buffers excluding BUFFER.
BUFFER nil or omitted means use the current buffer.
Like `internal-complete-buffer', but removes BUFFER from the completion list."
(lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer))))
(let ((except (if (stringp buffer) buffer (buffer-name buffer))))
(apply-partially 'completion-table-with-predicate
'internal-complete-buffer
(lambda (name)
@ -1879,13 +1873,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
;;; Old-style completion, used in Emacs-21 and Emacs-22.
(defun completion-emacs21-try-completion (string table pred point)
(defun completion-emacs21-try-completion (string table pred _point)
(let ((completion (try-completion string table pred)))
(if (stringp completion)
(cons completion (length completion))
completion)))
(defun completion-emacs21-all-completions (string table pred point)
(defun completion-emacs21-all-completions (string table pred _point)
(completion-hilit-commonality
(all-completions string table pred)
(length string)
@ -1942,10 +1936,9 @@ Return the new suffix."
(substring afterpoint 0 (cdr bounds)))))
(defun completion-basic-try-completion (string table pred point)
(lexical-let*
((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint)))
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint)))
(if (zerop (cdr bounds))
;; `try-completion' may return a subtly different result
;; than `all+merge', so try to use it whenever possible.
@ -1956,30 +1949,28 @@ Return the new suffix."
(concat completion
(completion--merge-suffix completion point afterpoint))
(length completion))))
(lexical-let*
((suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
(pattern (delete
"" (list (substring beforepoint (car bounds))
'point
(substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(let* ((suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
(pattern (delete
"" (list (substring beforepoint (car bounds))
'point
(substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(if minibuffer-completing-file-name
(setq all (completion-pcm--filename-try-filter all)))
(completion-pcm--merge-try pattern all prefix suffix)))))
(defun completion-basic-all-completions (string table pred point)
(lexical-let*
((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
(suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
(pattern (delete
"" (list (substring beforepoint (car bounds))
'point
(substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
;; (suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
(pattern (delete
"" (list (substring beforepoint (car bounds))
'point
(substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(completion-hilit-commonality all point (car bounds))))
;;; Partial-completion-mode style completion.
@ -2142,13 +2133,12 @@ POINT is a position inside STRING.
FILTER is a function applied to the return value, that can be used, e.g. to
filter out additional entries (because TABLE migth not obey PRED)."
(unless filter (setq filter 'identity))
(lexical-let*
((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
(prefix (substring beforepoint 0 (car bounds)))
(suffix (substring afterpoint (cdr bounds)))
firsterror)
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
(prefix (substring beforepoint 0 (car bounds)))
(suffix (substring afterpoint (cdr bounds)))
firsterror)
(setq string (substring string (car bounds) (+ point (cdr bounds))))
(let* ((relpoint (- point (car bounds)))
(pattern (completion-pcm--string->pattern string relpoint))
@ -2163,7 +2153,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
;; The prefix has no completions at all, so we should try and fix
;; that first.
(let ((substring (substring prefix 0 -1)))
(destructuring-bind (subpat suball subprefix subsuffix)
(destructuring-bind (subpat suball subprefix _subsuffix)
(completion-pcm--find-all-completions
substring table pred (length substring) filter)
(let ((sep (aref prefix (1- (length prefix))))
@ -2228,7 +2218,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
(list pattern all prefix suffix)))))
(defun completion-pcm-all-completions (string table pred point)
(destructuring-bind (pattern all &optional prefix suffix)
(destructuring-bind (pattern all &optional prefix _suffix)
(completion-pcm--find-all-completions string table pred point)
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
@ -2323,9 +2313,9 @@ filter out additional entries (because TABLE migth not obey PRED)."
(defun completion-pcm--pattern->string (pattern)
(mapconcat (lambda (x) (cond
((stringp x) x)
((eq x 'star) "*")
(t ""))) ;any, point, prefix.
((stringp x) x)
((eq x 'star) "*")
(t ""))) ;any, point, prefix.
pattern
""))
@ -2341,7 +2331,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
;; second alternative.
(defun completion-pcm--filename-try-filter (all)
"Filter to adjust `all' file completion to the behavior of `try'."
(when all
(when all
(let ((try ())
(re (concat "\\(?:\\`\\.\\.?/\\|"
(regexp-opt completion-ignored-extensions)
@ -2359,23 +2349,23 @@ filter out additional entries (because TABLE migth not obey PRED)."
(equal (completion-pcm--pattern->string pattern) (car all)))
t)
(t
(let* ((mergedpat (completion-pcm--merge-completions all pattern))
;; `mergedpat' is in reverse order. Place new point (by
;; order of preference) either at the old point, or at
;; the last place where there's something to choose, or
;; at the very end.
(pointpat (or (memq 'point mergedpat)
(memq 'any mergedpat)
(memq 'star mergedpat)
;; Not `prefix'.
mergedpat))
;; New pos from the start.
(newpos (length (completion-pcm--pattern->string pointpat)))
;; Do it afterwards because it changes `pointpat' by sideeffect.
(merged (completion-pcm--pattern->string (nreverse mergedpat))))
(let* ((mergedpat (completion-pcm--merge-completions all pattern))
;; `mergedpat' is in reverse order. Place new point (by
;; order of preference) either at the old point, or at
;; the last place where there's something to choose, or
;; at the very end.
(pointpat (or (memq 'point mergedpat)
(memq 'any mergedpat)
(memq 'star mergedpat)
;; Not `prefix'.
mergedpat))
;; New pos from the start.
(newpos (length (completion-pcm--pattern->string pointpat)))
;; Do it afterwards because it changes `pointpat' by sideeffect.
(merged (completion-pcm--pattern->string (nreverse mergedpat))))
(setq suffix (completion--merge-suffix merged newpos suffix))
(cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
(destructuring-bind (pattern all prefix suffix)
@ -2403,14 +2393,14 @@ filter out additional entries (because TABLE migth not obey PRED)."
(list all pattern prefix suffix (car bounds))))
(defun completion-substring-try-completion (string table pred point)
(destructuring-bind (all pattern prefix suffix carbounds)
(destructuring-bind (all pattern prefix suffix _carbounds)
(completion-substring--all-completions string table pred point)
(if minibuffer-completing-file-name
(setq all (completion-pcm--filename-try-filter all)))
(completion-pcm--merge-try pattern all prefix suffix)))
(defun completion-substring-all-completions (string table pred point)
(destructuring-bind (all pattern prefix suffix carbounds)
(destructuring-bind (all pattern prefix _suffix _carbounds)
(completion-substring--all-completions string table pred point)
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
@ -2447,12 +2437,12 @@ filter out additional entries (because TABLE migth not obey PRED)."
(concat (substring str 0 (car bounds))
(mapconcat 'string (substring str (car bounds)) sep))))))))
(defun completion-initials-all-completions (string table pred point)
(defun completion-initials-all-completions (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-all-completions newstr table pred (length newstr)))))
(defun completion-initials-try-completion (string table pred point)
(defun completion-initials-try-completion (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))

55
lisp/mpc.el
View File

@ -1,4 +1,4 @@
;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*-
;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
@ -341,9 +341,7 @@ CMD can be a string which is passed as-is to MPD or a list of strings
which will be concatenated with proper quoting before passing them to MPD."
(let ((proc (mpc-proc)))
(if (and callback (not (process-get proc 'ready)))
(lexical-let ((old (process-get proc 'callback))
(callback callback)
(cmd cmd))
(let ((old (process-get proc 'callback)))
(process-put proc 'callback
(lambda ()
(funcall old)
@ -359,15 +357,14 @@ which will be concatenated with proper quoting before passing them to MPD."
(mapconcat 'mpc--proc-quote-string cmd " "))
"\n")))
(if callback
(lexical-let ((buf (current-buffer))
(callback callback))
;; (let ((buf (current-buffer)))
(process-put proc 'callback
callback
;; (lambda ()
;; (funcall callback
;; (prog1 (current-buffer)
;; (set-buffer buf))))
))
;; (set-buffer buf)))))
)
;; If `callback' is nil, we're executing synchronously.
(process-put proc 'callback 'ignore)
;; This returns the process's buffer.
@ -402,8 +399,7 @@ which will be concatenated with proper quoting before passing them to MPD."
(defun mpc-proc-cmd-to-alist (cmd &optional callback)
(if callback
(lexical-let ((buf (current-buffer))
(callback callback))
(let ((buf (current-buffer)))
(mpc-proc-cmd cmd (lambda ()
(funcall callback (prog1 (mpc-proc-buf-to-alist
(current-buffer))
@ -522,7 +518,7 @@ to call FUN for any change whatsoever.")
(defun mpc-status-refresh (&optional callback)
"Refresh `mpc-status'."
(lexical-let ((cb callback))
(let ((cb callback))
(mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
(lambda ()
(mpc--status-callback)
@ -604,7 +600,7 @@ The songs are returned as alists."
(cond
((eq tag 'Playlist)
;; Special case for pseudo-tag playlist.
(let ((l (condition-case err
(let ((l (condition-case nil
(mpc-proc-buf-to-alists
(mpc-proc-cmd (list "listplaylistinfo" value)))
(mpc-proc-error
@ -637,7 +633,7 @@ The songs are returned as alists."
(mpc-union (mpc-cmd-find tag1 value)
(mpc-cmd-find tag2 value))))
(t
(condition-case err
(condition-case nil
(mpc-proc-buf-to-alists
(mpc-proc-cmd (list "find" (symbol-name tag) value)))
(mpc-proc-error
@ -775,7 +771,7 @@ The songs are returned as alists."
(defun mpc-cmd-pause (&optional arg callback)
"Pause or resume playback of the queue of songs."
(lexical-let ((cb callback))
(let ((cb callback))
(mpc-proc-cmd (list "pause" arg)
(lambda () (mpc-status-refresh) (if cb (funcall cb))))
(unless callback (mpc-proc-sync))))
@ -839,7 +835,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
(defun mpc-cmd-update (&optional arg callback)
(lexical-let ((cb callback))
(let ((cb callback))
(mpc-proc-cmd (if arg (list "update" arg) "update")
(lambda () (mpc-status-refresh) (if cb (funcall cb))))
(unless callback (mpc-proc-sync))))
@ -939,7 +935,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(defun mpc-tempfiles-clean ()
(let ((live ()))
(maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable)
(maphash (lambda (_k v) (push v live)) mpc-tempfiles-reftable)
(dolist (f mpc-tempfiles)
(unless (member f live) (ignore-errors (delete-file f))))
(setq mpc-tempfiles live)))
@ -1163,7 +1159,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(mpc-status-mode))
(mpc-proc-buffer (mpc-proc) 'status buf))
(if (null songs-win) (pop-to-buffer buf)
(let ((win (split-window songs-win 20 t)))
(let ((_win (split-window songs-win 20 t)))
(set-window-dedicated-p songs-win nil)
(set-window-buffer songs-win buf)
(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
(mpc-proc-cmd (list "seekid" songid time)
'mpc-status-refresh))))
(let ((status (mpc-cmd-status)))
(lexical-let* ((songid (cdr (assq 'songid status)))
(step step)
(let* ((songid (cdr (assq 'songid status)))
(time (if songid (string-to-number
(cdr (assq 'time status))))))
(let ((timer (run-with-timer
@ -2389,17 +2384,14 @@ This is used so that they can be compared with `eq', which is needed for
(if mpc--faster-toggle-timer
(mpc--faster-stop)
(mpc-status-refresh) (mpc-proc-sync)
(lexical-let* ((speedup speedup)
songid ;The ID of the currently ffwd/rewinding song.
songnb ;The position of that song in the playlist.
songduration ;The duration of that song.
songtime ;The time of the song last time we ran.
oldtime ;The timeoftheday last time we ran.
prevsongid) ;The song we're in the process leaving.
(let* (songid ;The ID of the currently ffwd/rewinding song.
songduration ;The duration of that song.
songtime ;The time of the song last time we ran.
oldtime ;The timeoftheday last time we ran.
prevsongid) ;The song we're in the process leaving.
(let ((fun
(lambda ()
(let ((newsongid (cdr (assq 'songid mpc-status)))
(newsongnb (cdr (assq 'song mpc-status))))
(let ((newsongid (cdr (assq 'songid mpc-status))))
(if (and (equal prevsongid newsongid)
(not (equal prevsongid songid)))
@ -2450,8 +2442,7 @@ This is used so that they can be compared with `eq', which is needed for
(mpc-proc-cmd
(list "seekid" songid songtime)
'mpc-status-refresh)
(mpc-proc-error (mpc-status-refresh)))))))
(setq songnb newsongnb)))))
(mpc-proc-error (mpc-status-refresh)))))))))))
(setq mpc--faster-toggle-forward (> step 0))
(funcall fun) ;Initialize values.
(setq mpc--faster-toggle-timer
@ -2461,13 +2452,13 @@ This is used so that they can be compared with `eq', which is needed for
(defvar mpc-faster-speedup 8)
(defun mpc-ffwd (event)
(defun mpc-ffwd (_event)
"Fast forward."
(interactive (list last-nonmenu-event))
;; (mpc--faster event 4.0 1)
(mpc--faster-toggle mpc-faster-speedup 1))
(defun mpc-rewind (event)
(defun mpc-rewind (_event)
"Fast rewind."
(interactive (list last-nonmenu-event))
;; (mpc--faster event 4.0 -1)

4
lisp/newcomment.el
View File

@ -1,4 +1,4 @@
;;; newcomment.el --- (un)comment regions of buffers
;;; newcomment.el --- (un)comment regions of buffers -*- lexical-binding: t -*-
;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
@ -722,7 +722,7 @@ With any other arg, set comment column to indentation of the previous comment
With prefix ARG, kill comments on that many lines starting with this one."
(interactive "P")
(comment-normalize-vars)
(dotimes (_ (prefix-numeric-value arg))
(dotimes (i (prefix-numeric-value arg))
(save-excursion
(beginning-of-line)
(let ((cs (comment-search-forward (line-end-position) t)))

2
lisp/reveal.el
View File

@ -1,4 +1,4 @@
;;; reveal.el --- Automatically reveal hidden text at point
;;; reveal.el --- Automatically reveal hidden text at point -*- lexical-binding: t -*-
;; Copyright (C) 2000-2011 Free Software Foundation, Inc.

144
lisp/server.el
View File

@ -1,4 +1,4 @@
;;; server.el --- Lisp code for GNU Emacs running as server process
;;; server.el --- Lisp code for GNU Emacs running as server process -*- lexical-binding: t -*-
;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc.
@ -335,9 +335,9 @@ If CLIENT is non-nil, add a description of it to the logged message."
(goto-char (point-max))
(insert (funcall server-log-time-function)
(cond
((null client) " ")
((listp client) (format " %s: " (car client)))
(t (format " %s: " client)))
((null client) " ")
((listp client) (format " %s: " (car client)))
(t (format " %s: " client)))
string)
(or (bolp) (newline)))))
@ -355,7 +355,7 @@ If CLIENT is non-nil, add a description of it to the logged message."
(and (process-contact proc :server)
(eq (process-status proc) 'closed)
(ignore-errors
(delete-file (process-get proc :server-file))))
(delete-file (process-get proc :server-file))))
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(server-delete-client proc))
@ -410,18 +410,19 @@ If CLIENT is non-nil, add a description of it to the logged message."
proc
;; See if this is the last frame for this client.
(>= 1 (let ((frame-num 0))
(dolist (f (frame-list))
(when (eq proc (frame-parameter f 'client))
(setq frame-num (1+ frame-num))))
frame-num)))
(dolist (f (frame-list))
(when (eq proc (frame-parameter f 'client))
(setq frame-num (1+ frame-num))))
frame-num)))
(server-log (format "server-handle-delete-frame, frame %s" frame) proc)
(server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later.
(defun server-handle-suspend-tty (terminal)
"Notify the emacsclient process to suspend itself when its tty device is suspended."
"Notify the client process that its tty device is suspended."
(dolist (proc (server-clients-with 'terminal terminal))
(server-log (format "server-handle-suspend-tty, terminal %s" terminal) proc)
(condition-case err
(server-log (format "server-handle-suspend-tty, terminal %s" terminal)
proc)
(condition-case nil
(server-send-string proc "-suspend \n")
(file-error ;The pipe/socket was closed.
(ignore-errors (server-delete-client proc))))))
@ -540,8 +541,8 @@ To force-start a server, do \\[server-force-delete] and then
(if (not (eq t (server-running-p server-name)))
;; Remove any leftover socket or authentication file
(ignore-errors
(let (delete-by-moving-to-trash)
(delete-file server-file)))
(let (delete-by-moving-to-trash)
(delete-file server-file)))
(setq server-mode nil) ;; already set by the minor mode code
(display-warning
'server
@ -596,11 +597,11 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
(when server-use-tcp
(let ((auth-key
(loop
;; The auth key is a 64-byte string of random chars in the
;; range `!'..`~'.
repeat 64
collect (+ 33 (random 94)) into auth
finally return (concat auth))))
;; The auth key is a 64-byte string of random chars in the
;; range `!'..`~'.
repeat 64
collect (+ 33 (random 94)) into auth
finally return (concat auth))))
(process-put server-process :auth-key auth-key)
(with-temp-file server-file
(set-buffer-multibyte nil)
@ -695,31 +696,31 @@ Server mode runs a process that accepts commands from the
(add-to-list 'frame-inherited-parameters 'client)
(let ((frame
(server-with-environment (process-get proc 'env)
'("LANG" "LC_CTYPE" "LC_ALL"
;; For tgetent(3); list according to ncurses(3).
"BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
"NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
"NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
"TERMINFO_DIRS" "TERMPATH"
;; rxvt wants these
"COLORFGBG" "COLORTERM")
(make-frame `((window-system . nil)
(tty . ,tty)
(tty-type . ,type)
;; Ignore nowait here; we always need to
;; clean up opened ttys when the client dies.
(client . ,proc)
;; This is a leftover from an earlier
;; attempt at making it possible for process
;; run in the server process to use the
;; environment of the client process.
;; It has no effect now and to make it work
;; we'd need to decide how to make
;; process-environment interact with client
;; envvars, and then to change the
;; C functions `child_setup' and
;; `getenv_internal' accordingly.
(environment . ,(process-get proc 'env)))))))
'("LANG" "LC_CTYPE" "LC_ALL"
;; For tgetent(3); list according to ncurses(3).
"BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES"
"NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING"
"NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO"
"TERMINFO_DIRS" "TERMPATH"
;; rxvt wants these
"COLORFGBG" "COLORTERM")
(make-frame `((window-system . nil)
(tty . ,tty)
(tty-type . ,type)
;; Ignore nowait here; we always need to
;; clean up opened ttys when the client dies.
(client . ,proc)
;; This is a leftover from an earlier
;; attempt at making it possible for process
;; run in the server process to use the
;; environment of the client process.
;; It has no effect now and to make it work
;; we'd need to decide how to make
;; process-environment interact with client
;; envvars, and then to change the
;; C functions `child_setup' and
;; `getenv_internal' accordingly.
(environment . ,(process-get proc 'env)))))))
;; ttys don't use the `display' parameter, but callproc.c does to set
;; the DISPLAY environment on subprocesses.
@ -783,8 +784,7 @@ Server mode runs a process that accepts commands from the
;; frame because input from that display will be blocked (until exiting
;; the minibuffer). Better exit this minibuffer right away.
;; Similarly with recursive-edits such as the splash screen.
(run-with-timer 0 nil (lexical-let ((proc proc))
(lambda () (server-execute-continuation proc))))
(run-with-timer 0 nil (lambda () (server-execute-continuation proc)))
(top-level)))
;; We use various special properties on process objects:
@ -978,7 +978,7 @@ The following commands are accepted by the client:
;; -resume: Resume a suspended tty frame.
(`"-resume"
(lexical-let ((terminal (process-get proc 'terminal)))
(let ((terminal (process-get proc 'terminal)))
(setq dontkill t)
(push (lambda ()
(when (eq (terminal-live-p terminal) t)
@ -989,7 +989,7 @@ The following commands are accepted by the client:
;; get out of sync, and a C-z sends a SIGTSTP to
;; emacsclient.)
(`"-suspend"
(lexical-let ((terminal (process-get proc 'terminal)))
(let ((terminal (process-get proc 'terminal)))
(setq dontkill t)
(push (lambda ()
(when (eq (terminal-live-p terminal) t)
@ -1036,7 +1036,7 @@ The following commands are accepted by the client:
(`"-eval"
(if use-current-frame
(setq use-current-frame 'always))
(lexical-let ((expr (pop args-left)))
(let ((expr (pop args-left)))
(if coding-system
(setq expr (decode-coding-string expr coding-system)))
(push (lambda () (server-eval-and-print expr proc))
@ -1081,23 +1081,15 @@ The following commands are accepted by the client:
(process-put
proc 'continuation
(lexical-let ((proc proc)
(files files)
(nowait nowait)
(commands commands)
(dontkill dontkill)
(frame frame)
(dir dir)
(tty-name tty-name))
(lambda ()
(with-current-buffer (get-buffer-create server-buffer)
;; Use the same cwd as the emacsclient, if possible, so
;; relative file names work correctly, even in `eval'.
(let ((default-directory
(if (and dir (file-directory-p dir))
dir default-directory)))
(server-execute proc files nowait commands
dontkill frame tty-name))))))
(lambda ()
(with-current-buffer (get-buffer-create server-buffer)
;; Use the same cwd as the emacsclient, if possible, so
;; relative file names work correctly, even in `eval'.
(let ((default-directory
(if (and dir (file-directory-p dir))
dir default-directory)))
(server-execute proc files nowait commands
dontkill frame tty-name)))))
(when (or frame files)
(server-goto-toplevel proc))
@ -1222,7 +1214,10 @@ so don't mark these buffers specially, just visit them normally."
(process-put proc 'buffers
(nconc (process-get proc 'buffers) client-record)))
client-record))
(defvar server-kill-buffer-running nil
"Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
(defun server-buffer-done (buffer &optional for-killing)
"Mark BUFFER as \"done\" for its client(s).
This 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."
(setq live-client t))))
(yes-or-no-p "This Emacs session has clients; exit anyway? ")))
(defvar server-kill-buffer-running nil
"Non-nil while `server-kill-buffer' or `server-buffer-done' is running.")
(defun server-kill-buffer ()
"Remove the current buffer from its clients' buffer list.
Designed 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,
starts server process and that is all. Invoked by \\[server-edit]."
(interactive "P")
(cond
((or arg
(not server-process)
(memq (process-status server-process) '(signal exit)))
(server-mode 1))
(server-clients (apply 'server-switch-buffer (server-done)))
(t (message "No server editing buffers exist"))))
((or arg
(not server-process)
(memq (process-status server-process) '(signal exit)))
(server-mode 1))
(server-clients (apply 'server-switch-buffer (server-done)))
(t (message "No server editing buffers exist"))))
(defun server-switch-buffer (&optional next-buffer killed-one filepos)
"Switch to another buffer, preferably one that has a client.

100
lisp/simple.el
View File

@ -28,8 +28,7 @@
;;; Code:
;; This is for lexical-let in apply-partially.
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl)) ;For define-minor-mode.
(declare-function widget-convert "wid-edit" (type &rest args))
(declare-function shell-mode "shell" ())
@ -1000,7 +999,7 @@ When called interactively, the word count is printed in echo area."
(goto-char (point-min))
(while (forward-word 1)
(setq count (1+ count)))))
(if (interactive-p)
(if (called-interactively-p 'interactive)
(message "Region has %d words" count))
count))
@ -1220,12 +1219,12 @@ this command arranges for all errors to enter the debugger."
current-prefix-arg))
(if (null eval-expression-debug-on-error)
(setq values (cons (eval eval-expression-arg) values))
(push (eval eval-expression-arg lexical-binding) values)
(let ((old-value (make-symbol "t")) new-value)
;; Bind debug-on-error to something unique so that we can
;; detect when evaled code changes it.
(let ((debug-on-error old-value))
(setq values (cons (eval eval-expression-arg) values))
(push (eval eval-expression-arg lexical-binding) values)
(setq new-value debug-on-error))
;; If evaled code has changed the value of debug-on-error,
;; propagate that change to the global binding.
@ -2829,51 +2828,6 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]."
(reset-this-command-lengths)
(restore-overriding-map))
;; This function is here rather than in subr.el because it uses CL.
(defmacro with-wrapper-hook (var args &rest body)
"Run BODY wrapped with the VAR hook.
VAR is a special hook: its functions are called with a first argument
which is the \"original\" code (the BODY), so the hook function can wrap
the original function, or call it any number of times (including not calling
it at all). This is similar to an `around' advice.
VAR is normally a symbol (a variable) in which case it is treated like
a hook, with a buffer-local and a global part. But it can also be an
arbitrary expression.
ARGS is a list of variables which will be passed as additional arguments
to each function, after the initial argument, and which the first argument
expects to receive when called."
(declare (indent 2) (debug t))
;; We need those two gensyms because CL's lexical scoping is not available
;; for function arguments :-(
(let ((funs (make-symbol "funs"))
(global (make-symbol "global"))
(argssym (make-symbol "args")))
;; Since the hook is a wrapper, the loop has to be done via
;; recursion: a given hook function will call its parameter in order to
;; continue looping.
`(labels ((runrestofhook (,funs ,global ,argssym)
;; `funs' holds the functions left on the hook and `global'
;; holds the functions left on the global part of the hook
;; (in case the hook is local).
(lexical-let ((funs ,funs)
(global ,global))
(if (consp funs)
(if (eq t (car funs))
(runrestofhook
(append global (cdr funs)) nil ,argssym)
(apply (car funs)
(lambda (&rest ,argssym)
(runrestofhook (cdr funs) global ,argssym))
,argssym))
;; Once there are no more functions on the hook, run
;; the original body.
(apply (lambda ,args ,@body) ,argssym)))))
(runrestofhook ,var
;; The global part of the hook, if any.
,(if (symbolp var)
`(if (local-variable-p ',var)
(default-value ',var)))
(list ,@args)))))
(defvar filter-buffer-substring-functions nil
"Wrapper hook around `filter-buffer-substring'.
@ -6652,37 +6606,25 @@ saving the value of `buffer-invisibility-spec' and setting it to nil."
buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
;; Partial application of functions (similar to "currying").
;; This function is here rather than in subr.el because it uses CL.
(defun apply-partially (fun &rest args)
"Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
The result is a new function which does the same as FUN, except that
the first N arguments are fixed at the values with which this function
was called."
(lexical-let ((fun fun) (args1 args))
(lambda (&rest args2) (apply fun (append args1 args2)))))
;; Minibuffer prompt stuff.
;(defun minibuffer-prompt-modification (start end)
; (error "You cannot modify the prompt"))
;
;
;(defun minibuffer-prompt-insertion (start end)
; (let ((inhibit-modification-hooks t))
; (delete-region start end)
; ;; Discard undo information for the text insertion itself
; ;; and for the text deletion.above.
; (when (consp buffer-undo-list)
; (setq buffer-undo-list (cddr buffer-undo-list)))
; (message "You cannot modify the prompt")))
;
;
;(setq minibuffer-prompt-properties
; (list 'modification-hooks '(minibuffer-prompt-modification)
; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
;
;;(defun minibuffer-prompt-modification (start end)
;; (error "You cannot modify the prompt"))
;;
;;
;;(defun minibuffer-prompt-insertion (start end)
;; (let ((inhibit-modification-hooks t))
;; (delete-region start end)
;; ;; Discard undo information for the text insertion itself
;; ;; and for the text deletion.above.
;; (when (consp buffer-undo-list)
;; (setq buffer-undo-list (cddr buffer-undo-list)))
;; (message "You cannot modify the prompt")))
;;
;;
;;(setq minibuffer-prompt-properties
;; (list 'modification-hooks '(minibuffer-prompt-modification)
;; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
;;;; Problematic external packages.

257
lisp/startup.el
View File

@ -1,4 +1,4 @@
;;; startup.el --- process Emacs shell arguments
;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1992, 1994-2011 Free Software Foundation, Inc.
@ -98,6 +98,7 @@ the remaining command-line args are in the variable `command-line-args-left'.")
"List of command-line args not yet processed.")
(defvaralias 'argv 'command-line-args-left
;; FIXME: Bad name for a dynamically bound variable.
"List of command-line args not yet processed.
This is a convenience alias, so that one can write \(pop argv\)
inside 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."
:type '(choice (const :tag "none" nil) string)
:group 'initialization
:initialize 'custom-initialize-default
:set (lambda (variable value)
:set (lambda (_variable _value)
(error "Customizing `site-run-file' does not work")))
(defcustom mail-host-address nil
@ -1095,7 +1096,8 @@ the `--debug-init' option to view a complete error backtrace."
user-init-file
(get (car error) 'error-message)
(if (cdr error) ": " "")
(mapconcat (lambda (s) (prin1-to-string s t)) (cdr error) ", "))
(mapconcat (lambda (s) (prin1-to-string s t))
(cdr error) ", "))
:warning)
(setq init-file-had-error t))))
@ -1291,25 +1293,25 @@ If this is nil, no message will be displayed."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst fancy-startup-text
'((:face (variable-pitch (:foreground "red"))
`((:face (variable-pitch (:foreground "red"))
"Welcome to "
:link ("GNU Emacs"
(lambda (button) (browse-url "http://www.gnu.org/software/emacs/"))
,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
"Browse http://www.gnu.org/software/emacs/")
", one component of the "
:link
(lambda ()
,(lambda ()
(if (eq system-type 'gnu/linux)
'("GNU/Linux"
(lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
`("GNU/Linux"
,(lambda (_button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
"Browse http://www.gnu.org/gnu/linux-and-gnu.html")
'("GNU" (lambda (button) (describe-gnu-project))
`("GNU" ,(lambda (_button) (describe-gnu-project))
"Display info on the GNU project")))
" operating system.\n\n"
:face variable-pitch
:link ("Emacs Tutorial" (lambda (button) (help-with-tutorial)))
:link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
"\tLearn basic keystroke commands"
(lambda ()
,(lambda ()
(let* ((en "TUTORIAL")
(tut (or (get-language-info current-language-environment
'tutorial)
@ -1327,19 +1329,20 @@ If this is nil, no message will be displayed."
(concat " (" title ")"))))
"\n"
:link ("Emacs Guided Tour"
(lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/"))
,(lambda (_button)
(browse-url "http://www.gnu.org/software/emacs/tour/"))
"Browse http://www.gnu.org/software/emacs/tour/")
"\tOverview of Emacs features at gnu.org\n"
:link ("View Emacs Manual" (lambda (button) (info-emacs-manual)))
:link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
"\tView the Emacs manual using Info\n"
:link ("Absence of Warranty" (lambda (button) (describe-no-warranty)))
:link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
:face (variable-pitch (:slant oblique))
"ABSOLUTELY NO WARRANTY\n"
:face variable-pitch
:link ("Copying Conditions" (lambda (button) (describe-copying)))
:link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
"\tConditions for redistributing and changing Emacs\n"
:link ("Ordering Manuals" (lambda (button) (view-order-manuals)))
:link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
"\tPurchasing printed copies of manuals\n"
"\n"))
"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
`:face FACE', like `fancy-splash-insert' accepts them.")
(defconst fancy-about-text
'((:face (variable-pitch (:foreground "red"))
`((:face (variable-pitch (:foreground "red"))
"This is "
:link ("GNU Emacs"
(lambda (button) (browse-url "http://www.gnu.org/software/emacs/"))
,(lambda (_button) (browse-url "http://www.gnu.org/software/emacs/"))
"Browse http://www.gnu.org/software/emacs/")
", one component of the "
:link
(lambda ()
,(lambda ()
(if (eq system-type 'gnu/linux)
'("GNU/Linux"
(lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
`("GNU/Linux"
,(lambda (_button)
(browse-url "http://www.gnu.org/gnu/linux-and-gnu.html"))
"Browse http://www.gnu.org/gnu/linux-and-gnu.html")
'("GNU" (lambda (button) (describe-gnu-project))
`("GNU" ,(lambda (_button) (describe-gnu-project))
"Display info on the GNU project.")))
" operating system.\n"
:face (lambda ()
:face ,(lambda ()
(list 'variable-pitch
(list :foreground
(if (eq (frame-parameter nil 'background-mode) 'dark)
"cyan" "darkblue"))))
"\n"
(lambda () (emacs-version))
,(lambda () (emacs-version))
"\n"
:face (variable-pitch (:height 0.8))
(lambda () emacs-copyright)
,(lambda () emacs-copyright)
"\n\n"
:face variable-pitch
:link ("Authors"
(lambda (button)
,(lambda (_button)
(view-file (expand-file-name "AUTHORS" data-directory))
(goto-char (point-min))))
"\tMany people have contributed code included in GNU Emacs\n"
:link ("Contributing"
(lambda (button)
,(lambda (_button)
(view-file (expand-file-name "CONTRIBUTE" data-directory))
(goto-char (point-min))))
"\tHow to contribute improvements to Emacs\n"
"\n"
:link ("GNU and Freedom" (lambda (button) (describe-gnu-project)))
:link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project)))
"\tWhy we developed GNU Emacs, and the GNU operating system\n"
:link ("Absence of Warranty" (lambda (button) (describe-no-warranty)))
:link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
:face (variable-pitch (:slant oblique))
"ABSOLUTELY NO WARRANTY\n"
:face variable-pitch
:link ("Copying Conditions" (lambda (button) (describe-copying)))
:link ("Copying Conditions" ,(lambda (_button) (describe-copying)))
"\tConditions for redistributing and changing Emacs\n"
:link ("Getting New Versions" (lambda (button) (describe-distribution)))
:link ("Getting New Versions" ,(lambda (_button) (describe-distribution)))
"\tHow to obtain the latest version of Emacs\n"
:link ("Ordering Manuals" (lambda (button) (view-order-manuals)))
:link ("Ordering Manuals" ,(lambda (_button) (view-order-manuals)))
"\tBuying printed manuals from the FSF\n"
"\n"
:link ("Emacs Tutorial" (lambda (button) (help-with-tutorial)))
:link ("Emacs Tutorial" ,(lambda (_button) (help-with-tutorial)))
"\tLearn basic Emacs keystroke commands"
(lambda ()
,(lambda ()
(let* ((en "TUTORIAL")
(tut (or (get-language-info current-language-environment
'tutorial)
@ -1419,7 +1423,8 @@ Each element in the list should be a list of strings or pairs
(concat " (" title ")"))))
"\n"
:link ("Emacs Guided Tour"
(lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/"))
,(lambda (_button)
(browse-url "http://www.gnu.org/software/emacs/tour/"))
"Browse http://www.gnu.org/software/emacs/tour/")
"\tSee an overview of Emacs features at gnu.org"
))
@ -1526,7 +1531,7 @@ a face or button specification."
(make-button (prog1 (point) (insert-image img)) (point)
'face 'default
'help-echo "mouse-2, RET: Browse http://www.gnu.org/"
'action (lambda (button) (browse-url "http://www.gnu.org/"))
'action (lambda (_button) (browse-url "http://www.gnu.org/"))
'follow-link t)
(insert "\n\n")))))
@ -1538,16 +1543,16 @@ a face or button specification."
(fancy-splash-insert
:face 'variable-pitch
"\nTo start... "
:link '("Open a File"
(lambda (button) (call-interactively 'find-file))
:link `("Open a File"
,(lambda (_button) (call-interactively 'find-file))
"Specify a new file's name, to edit the file")
" "
:link '("Open Home Directory"
(lambda (button) (dired "~"))
:link `("Open Home Directory"
,(lambda (_button) (dired "~"))
"Open your home directory, to operate on its files")
" "
:link '("Customize Startup"
(lambda (button) (customize-group 'initialization))
:link `("Customize Startup"
,(lambda (_button) (customize-group 'initialization))
"Change initialization settings including this screen")
"\n"))
(fancy-splash-insert
@ -1586,15 +1591,15 @@ a face or button specification."
(when concise
(fancy-splash-insert
:face 'variable-pitch "\n"
:link '("Dismiss this startup screen"
(lambda (button)
(when startup-screen-inhibit-startup-screen
(customize-set-variable 'inhibit-startup-screen t)
(customize-mark-to-save 'inhibit-startup-screen)
(custom-save-all))
(let ((w (get-buffer-window "*GNU Emacs*")))
(and w (not (one-window-p)) (delete-window w)))
(kill-buffer "*GNU Emacs*")))
:link `("Dismiss this startup screen"
,(lambda (_button)
(when startup-screen-inhibit-startup-screen
(customize-set-variable 'inhibit-startup-screen t)
(customize-mark-to-save 'inhibit-startup-screen)
(custom-save-all))
(let ((w (get-buffer-window "*GNU Emacs*")))
(and w (not (one-window-p)) (delete-window w)))
(kill-buffer "*GNU Emacs*")))
" ")
(when (or user-init-file custom-file)
(let ((checked (create-image "checked.xpm"
@ -1809,37 +1814,37 @@ To quit a partially entered command, type Control-g.\n")
(insert "\nImportant Help menu items:\n")
(insert-button "Emacs Tutorial"
'action (lambda (button) (help-with-tutorial))
'action (lambda (_button) (help-with-tutorial))
'follow-link t)
(insert "\t\tLearn basic Emacs keystroke commands\n")
(insert-button "Read the Emacs Manual"
'action (lambda (button) (info-emacs-manual))
'action (lambda (_button) (info-emacs-manual))
'follow-link t)
(insert "\tView the Emacs manual using Info\n")
(insert-button "\(Non)Warranty"
'action (lambda (button) (describe-no-warranty))
'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
(insert-button "Copying Conditions"
'action (lambda (button) (describe-copying))
'action (lambda (_button) (describe-copying))
'follow-link t)
(insert "\tConditions for redistributing and changing Emacs\n")
(insert-button "More Manuals / Ordering Manuals"
'action (lambda (button) (view-order-manuals))
'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert " How to order printed manuals from the FSF\n")
(insert "\nUseful tasks:\n")
(insert-button "Visit New File"
'action (lambda (button) (call-interactively 'find-file))
'action (lambda (_button) (call-interactively 'find-file))
'follow-link t)
(insert "\t\tSpecify a new file's name, to edit the file\n")
(insert-button "Open Home Directory"
'action (lambda (button) (dired "~"))
'action (lambda (_button) (dired "~"))
'follow-link t)
(insert "\tOpen your home directory, to operate on its files\n")
(insert-button "Customize Startup"
'action (lambda (button) (customize-group 'initialization))
'action (lambda (_button) (customize-group 'initialization))
'follow-link t)
(insert "\tChange initialization settings including this screen\n")
@ -1873,20 +1878,20 @@ To quit a partially entered command, type Control-g.\n")
(where (key-description where))
(t "M-x help")))))
(insert-button "Emacs manual"
'action (lambda (button) (info-emacs-manual))
'action (lambda (_button) (info-emacs-manual))
'follow-link t)
(insert (substitute-command-keys"\t \\[info-emacs-manual]\t"))
(insert-button "Browse manuals"
'action (lambda (button) (Info-directory))
'action (lambda (_button) (Info-directory))
'follow-link t)
(insert (substitute-command-keys "\t \\[info]\n"))
(insert-button "Emacs tutorial"
'action (lambda (button) (help-with-tutorial))
'action (lambda (_button) (help-with-tutorial))
'follow-link t)
(insert (substitute-command-keys
"\t \\[help-with-tutorial]\tUndo changes\t \\[undo]\n"))
(insert-button "Buy manuals"
'action (lambda (button) (view-order-manuals))
'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert (substitute-command-keys
"\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")
;; Say how to use the menu bar with the keyboard.
(insert "\n")
(insert-button "Activate menubar"
'action (lambda (button) (tmm-menubar))
'action (lambda (_button) (tmm-menubar))
'follow-link t)
(if (and (eq (key-binding "\M-`") 'tmm-menubar)
(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.)")
(insert "\nUseful tasks:\n")
(insert-button "Visit New File"
'action (lambda (button) (call-interactively 'find-file))
'action (lambda (_button) (call-interactively 'find-file))
'follow-link t)
(insert "\t\t\t")
(insert-button "Open Home Directory"
'action (lambda (button) (dired "~"))
'action (lambda (_button) (dired "~"))
'follow-link t)
(insert "\n")
(insert-button "Customize Startup"
'action (lambda (button) (customize-group 'initialization))
'action (lambda (_button) (customize-group 'initialization))
'follow-link t)
(insert "\t\t")
(insert-button "Open *scratch* buffer"
'action (lambda (button) (switch-to-buffer
(get-buffer-create "*scratch*")))
'action (lambda (_button) (switch-to-buffer
(get-buffer-create "*scratch*")))
'follow-link t)
(insert "\n")
(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.)")
"
GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ")
(insert-button "full details"
'action (lambda (button) (describe-no-warranty))
'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert ".
Emacs is Free Software--Free as in Freedom--so you can redistribute copies
of Emacs and modify it; type C-h C-c to see ")
(insert-button "the conditions"
'action (lambda (button) (describe-copying))
'action (lambda (_button) (describe-copying))
'follow-link t)
(insert ".
Type C-h C-d for information on ")
(insert-button "getting the latest version"
'action (lambda (button) (describe-distribution))
'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert "."))
(insert (substitute-command-keys
"
GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for "))
(insert-button "full details"
'action (lambda (button) (describe-no-warranty))
'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert (substitute-command-keys ".
Emacs is Free Software--Free as in Freedom--so you can redistribute copies
of Emacs and modify it; type \\[describe-copying] to see "))
(insert-button "the conditions"
'action (lambda (button) (describe-copying))
'action (lambda (_button) (describe-copying))
'follow-link t)
(insert (substitute-command-keys".
Type \\[describe-distribution] for information on "))
(insert-button "getting the latest version"
'action (lambda (button) (describe-distribution))
'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert ".")))
@ -1977,7 +1982,7 @@ Type \\[describe-distribution] for information on "))
(insert-button "Authors"
'action
(lambda (button)
(lambda (_button)
(view-file (expand-file-name "AUTHORS" data-directory))
(goto-char (point-min)))
'follow-link t)
@ -1985,34 +1990,34 @@ Type \\[describe-distribution] for information on "))
(insert-button "Contributing"
'action
(lambda (button)
(lambda (_button)
(view-file (expand-file-name "CONTRIBUTE" data-directory))
(goto-char (point-min)))
'follow-link t)
(insert "\tHow to contribute improvements to Emacs\n\n")
(insert-button "GNU and Freedom"
'action (lambda (button) (describe-gnu-project))
'action (lambda (_button) (describe-gnu-project))
'follow-link t)
(insert "\t\tWhy we developed GNU Emacs and the GNU system\n")
(insert-button "Absence of Warranty"
'action (lambda (button) (describe-no-warranty))
'action (lambda (_button) (describe-no-warranty))
'follow-link t)
(insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n")
(insert-button "Copying Conditions"
'action (lambda (button) (describe-copying))
'action (lambda (_button) (describe-copying))
'follow-link t)
(insert "\tConditions for redistributing and changing Emacs\n")
(insert-button "Getting New Versions"
'action (lambda (button) (describe-distribution))
'action (lambda (_button) (describe-distribution))
'follow-link t)
(insert "\tHow to get the latest version of GNU Emacs\n")
(insert-button "More Manuals / Ordering Manuals"
'action (lambda (button) (view-order-manuals))
'action (lambda (_button) (view-order-manuals))
'follow-link t)
(insert "\tBuying printed manuals from the FSF\n"))
@ -2078,7 +2083,7 @@ A fancy display is used on graphic displays, normal otherwise."
(defalias 'about-emacs 'display-about-screen)
(defalias 'display-splash-screen 'display-startup-screen)
(defun command-line-1 (command-line-args-left)
(defun command-line-1 (args-left)
(display-startup-echo-area-message)
(when (and pure-space-overflow
(not noninteractive))
@ -2089,14 +2094,12 @@ A fancy display is used on graphic displays, normal otherwise."
:warning))
(let ((file-count 0)
(command-line-args-left args-left)
first-file-buffer)
(when command-line-args-left
;; We have command args; process them.
;; Note that any local variables in this function affect the
;; ability of -f batch-byte-compile to detect free variables.
;; So we give some of them with common names a cl1- prefix.
(let ((cl1-dir command-line-default-directory)
cl1-tem
(let ((dir command-line-default-directory)
tem
;; This approach loses for "-batch -L DIR --eval "(require foo)",
;; if foo is intended to be found in DIR.
;;
@ -2119,8 +2122,8 @@ A fancy display is used on graphic displays, normal otherwise."
"--find-file" "--visit" "--file" "--no-desktop")
(mapcar (lambda (elt) (concat "-" (car elt)))
command-switch-alist)))
(cl1-line 0)
(cl1-column 0))
(line 0)
(column 0))
;; Add the long X options to longopts.
(dolist (tem command-line-x-option-alist)
@ -2161,12 +2164,12 @@ A fancy display is used on graphic displays, normal otherwise."
argi orig-argi)))))
;; Execute the option.
(cond ((setq cl1-tem (assoc argi command-switch-alist))
(cond ((setq tem (assoc argi command-switch-alist))
(if argval
(let ((command-line-args-left
(cons argval command-line-args-left)))
(funcall (cdr cl1-tem) argi))
(funcall (cdr cl1-tem) argi)))
(funcall (cdr tem) argi))
(funcall (cdr tem) argi)))
((equal argi "-no-splash")
(setq inhibit-startup-screen t))
@ -2175,22 +2178,22 @@ A fancy display is used on graphic displays, normal otherwise."
"-funcall"
"-e")) ; what the source used to say
(setq inhibit-startup-screen t)
(setq cl1-tem (intern (or argval (pop command-line-args-left))))
(if (commandp cl1-tem)
(command-execute cl1-tem)
(funcall cl1-tem)))
(setq tem (intern (or argval (pop command-line-args-left))))
(if (commandp tem)
(command-execute tem)
(funcall tem)))
((member argi '("-eval" "-execute"))
(setq inhibit-startup-screen t)
(eval (read (or argval (pop command-line-args-left)))))
((member argi '("-L" "-directory"))
(setq cl1-tem (expand-file-name
(setq tem (expand-file-name
(command-line-normalize-file-name
(or argval (pop command-line-args-left)))))
(cond (splice (setcdr splice (cons cl1-tem (cdr splice)))
(cond (splice (setcdr splice (cons tem (cdr splice)))
(setq splice (cdr splice)))
(t (setq load-path (cons cl1-tem load-path)
(t (setq load-path (cons tem load-path)
splice load-path))))
((member argi '("-l" "-load"))
@ -2214,10 +2217,10 @@ A fancy display is used on graphic displays, normal otherwise."
((equal argi "-insert")
(setq inhibit-startup-screen t)
(setq cl1-tem (or argval (pop command-line-args-left)))
(or (stringp cl1-tem)
(setq tem (or argval (pop command-line-args-left)))
(or (stringp tem)
(error "File name omitted from `-insert' option"))
(insert-file-contents (command-line-normalize-file-name cl1-tem)))
(insert-file-contents (command-line-normalize-file-name tem)))
((equal argi "-kill")
(kill-emacs t))
@ -2230,42 +2233,42 @@ A fancy display is used on graphic displays, normal otherwise."
(message "\"--no-desktop\" ignored because the Desktop package is not loaded"))
((string-match "^\\+[0-9]+\\'" argi)
(setq cl1-line (string-to-number argi)))
(setq line (string-to-number argi)))
((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi)
(setq cl1-line (string-to-number (match-string 1 argi))
cl1-column (string-to-number (match-string 2 argi))))
(setq line (string-to-number (match-string 1 argi))
column (string-to-number (match-string 2 argi))))
((setq cl1-tem (assoc orig-argi command-line-x-option-alist))
((setq tem (assoc orig-argi command-line-x-option-alist))
;; Ignore X-windows options and their args if not using X.
(setq command-line-args-left
(nthcdr (nth 1 cl1-tem) command-line-args-left)))
(nthcdr (nth 1 tem) command-line-args-left)))
((setq cl1-tem (assoc orig-argi command-line-ns-option-alist))
((setq tem (assoc orig-argi command-line-ns-option-alist))
;; Ignore NS-windows options and their args if not using NS.
(setq command-line-args-left
(nthcdr (nth 1 cl1-tem) command-line-args-left)))
(nthcdr (nth 1 tem) command-line-args-left)))
((member argi '("-find-file" "-file" "-visit"))
(setq inhibit-startup-screen t)
;; An explicit option to specify visiting a file.
(setq cl1-tem (or argval (pop command-line-args-left)))
(unless (stringp cl1-tem)
(setq tem (or argval (pop command-line-args-left)))
(unless (stringp tem)
(error "File name omitted from `%s' option" argi))
(setq file-count (1+ file-count))
(let ((file (expand-file-name
(command-line-normalize-file-name cl1-tem)
cl1-dir)))
(command-line-normalize-file-name tem)
dir)))
(if (= file-count 1)
(setq first-file-buffer (find-file file))
(find-file-other-window file)))
(unless (zerop cl1-line)
(unless (zerop line)
(goto-char (point-min))
(forward-line (1- cl1-line)))
(setq cl1-line 0)
(unless (< cl1-column 1)
(move-to-column (1- cl1-column)))
(setq cl1-column 0))
(forward-line (1- line)))
(setq line 0)
(unless (< column 1)
(move-to-column (1- column)))
(setq column 0))
;; These command lines now have no effect.
((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi)
@ -2293,19 +2296,19 @@ A fancy display is used on graphic displays, normal otherwise."
(let ((file
(expand-file-name
(command-line-normalize-file-name orig-argi)
cl1-dir)))
dir)))
(cond ((= file-count 1)
(setq first-file-buffer (find-file file)))
(inhibit-startup-screen
(find-file-other-window file))
(t (find-file file))))
(unless (zerop cl1-line)
(unless (zerop line)
(goto-char (point-min))
(forward-line (1- cl1-line)))
(setq cl1-line 0)
(unless (< cl1-column 1)
(move-to-column (1- cl1-column)))
(setq cl1-column 0))))))
(forward-line (1- line)))
(setq line 0)
(unless (< column 1)
(move-to-column (1- column)))
(setq column 0))))))
;; In unusual circumstances, the execution of Lisp code due
;; to command-line options can cause the last visible frame
;; to be deleted. In this case, kill emacs to avoid an

215
lisp/subr.el
View File

@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions.
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
;; Partial application of functions (similar to "currying").
;; This function is here rather than in subr.el because it uses CL.
(defun apply-partially (fun &rest args)
"Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
The result is a new function which does the same as FUN, except that
the first N arguments are fixed at the values with which this function
was called."
`(closure (t) (&rest args)
(apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
(if (null (featurep 'cl))
(progn
;; If we reload subr.el after having loaded CL, be careful not to
@ -163,8 +174,6 @@ value of last one, or nil if there are none.
;; If we reload subr.el after having loaded CL, be careful not to
;; overwrite CL's extended definition of `dolist', `dotimes',
;; `declare', `push' and `pop'.
(defvar --dolist-tail-- nil
"Temporary variable used in `dolist' expansion.")
(defmacro dolist (spec &rest body)
"Loop over a list.
@ -176,18 +185,29 @@ Then evaluate RESULT to get return value, default nil.
;; It would be cleaner to create an uninterned symbol,
;; but that uses a lot more space when many functions in many files
;; use dolist.
;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dolist-tail--))
`(let ((,temp ,(nth 1 spec))
,(car spec))
(while ,temp
(setq ,(car spec) (car ,temp))
,@body
(setq ,temp (cdr ,temp)))
,@(if (cdr (cdr spec))
`((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
(defvar --dotimes-limit-- nil
"Temporary variable used in `dotimes' expansion.")
;; This is not a reliable test, but it does not matter because both
;; semantics are acceptable, tho one is slightly faster with dynamic
;; scoping and the other is slightly faster (and has cleaner semantics)
;; with lexical scoping.
(if lexical-binding
`(let ((,temp ,(nth 1 spec)))
(while ,temp
(let ((,(car spec) (car ,temp)))
,@body
(setq ,temp (cdr ,temp))))
,@(if (cdr (cdr spec))
;; FIXME: This let often leads to "unused var" warnings.
`((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
`(let ((,temp ,(nth 1 spec))
,(car spec))
(while ,temp
(setq ,(car spec) (car ,temp))
,@body
(setq ,temp (cdr ,temp)))
,@(if (cdr (cdr spec))
`((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
(defmacro dotimes (spec &rest body)
"Loop a certain number of times.
@ -200,15 +220,30 @@ the return value (nil if RESULT is omitted).
;; It would be cleaner to create an uninterned symbol,
;; but that uses a lot more space when many functions in many files
;; use dotimes.
;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dotimes-limit--)
(start 0)
(end (nth 1 spec)))
`(let ((,temp ,end)
(,(car spec) ,start))
(while (< ,(car spec) ,temp)
,@body
(setq ,(car spec) (1+ ,(car spec))))
,@(cdr (cdr spec)))))
;; This is not a reliable test, but it does not matter because both
;; semantics are acceptable, tho one is slightly faster with dynamic
;; scoping and the other has cleaner semantics.
(if lexical-binding
(let ((counter '--dotimes-counter--))
`(let ((,temp ,end)
(,counter ,start))
(while (< ,counter ,temp)
(let ((,(car spec) ,counter))
,@body)
(setq ,counter (1+ ,counter)))
,@(if (cddr spec)
;; FIXME: This let often leads to "unused var" warnings.
`((let ((,(car spec) ,counter)) ,@(cddr spec))))))
`(let ((,temp ,end)
(,(car spec) ,start))
(while (< ,(car spec) ,temp)
,@body
(setq ,(car spec) (1+ ,(car spec))))
,@(cdr (cdr spec))))))
(defmacro declare (&rest specs)
"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
configuration."
(and (consp object)
(eq (car object) 'frame-configuration)))
(defun functionp (object)
"Non-nil if OBJECT is a function."
(or (and (symbolp object) (fboundp object)
(condition-case nil
(setq object (indirect-function object))
(error nil))
(eq (car-safe object) 'autoload)
(not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
(and (subrp object)
;; Filter out special forms.
(not (eq 'unevalled (cdr (subr-arity object)))))
(byte-code-function-p object)
(eq (car-safe object) 'lambda)))
;;;; List functions.
@ -1258,6 +1279,67 @@ the hook's buffer-local value rather than its default value."
(kill-local-variable hook)
(set hook hook-value))))))
(defmacro letrec (binders &rest body)
"Bind variables according to BINDERS then eval BODY.
The value of the last form in BODY is returned.
Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds
SYMBOL to the value of VALUEFORM.
All symbols are bound before the VALUEFORMs are evalled."
;; Only useful in lexical-binding mode.
;; As a special-form, we could implement it more efficiently (and cleanly,
;; making the vars actually unbound during evaluation of the binders).
(declare (debug let) (indent 1))
`(let ,(mapcar #'car binders)
,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
,@body))
(defmacro with-wrapper-hook (var args &rest body)
"Run BODY wrapped with the VAR hook.
VAR is a special hook: its functions are called with a first argument
which is the \"original\" code (the BODY), so the hook function can wrap
the original function, or call it any number of times (including not calling
it at all). This is similar to an `around' advice.
VAR is normally a symbol (a variable) in which case it is treated like
a hook, with a buffer-local and a global part. But it can also be an
arbitrary expression.
ARGS is a list of variables which will be passed as additional arguments
to each function, after the initial argument, and which the first argument
expects to receive when called."
(declare (indent 2) (debug t))
;; We need those two gensyms because CL's lexical scoping is not available
;; for function arguments :-(
(let ((funs (make-symbol "funs"))
(global (make-symbol "global"))
(argssym (make-symbol "args"))
(runrestofhook (make-symbol "runrestofhook")))
;; Since the hook is a wrapper, the loop has to be done via
;; recursion: a given hook function will call its parameter in order to
;; continue looping.
`(letrec ((,runrestofhook
(lambda (,funs ,global ,argssym)
;; `funs' holds the functions left on the hook and `global'
;; holds the functions left on the global part of the hook
;; (in case the hook is local).
(if (consp ,funs)
(if (eq t (car ,funs))
(funcall ,runrestofhook
(append ,global (cdr ,funs)) nil ,argssym)
(apply (car ,funs)
(apply-partially
(lambda (,funs ,global &rest ,argssym)
(funcall ,runrestofhook ,funs ,global ,argssym))
(cdr ,funs) ,global)
,argssym))
;; Once there are no more functions on the hook, run
;; the original body.
(apply (lambda ,args ,@body) ,argssym)))))
(funcall ,runrestofhook ,var
;; The global part of the hook, if any.
,(if (symbolp var)
`(if (local-variable-p ',var)
(default-value ',var)))
(list ,@args)))))
(defun add-to-list (list-var element &optional append compare-fn)
"Add ELEMENT to the value of LIST-VAR if it isn't there yet.
The test for presence of ELEMENT is done with `equal',
@ -1630,6 +1712,8 @@ This function makes or adds to an entry on `after-load-alist'."
(unless elt
(setq elt (list regexp-or-feature))
(push elt after-load-alist))
;; Make sure `form' is evalled in the current lexical/dynamic code.
(setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
(when (symbolp regexp-or-feature)
;; For features, the after-load-alist elements get run when `provide' is
;; called rather than at the end of the file. So add an indirection to
@ -2763,6 +2847,71 @@ nor the buffer list."
(when (buffer-live-p ,old-buffer)
(set-buffer ,old-buffer))))))
(defmacro save-window-excursion (&rest body)
"Execute BODY, preserving window sizes and contents.
Return the value of the last form in BODY.
Restore which buffer appears in which window, where display starts,
and the value of point and mark for each window.
Also restore the choice of selected window.
Also restore which buffer is current.
Does not restore the value of point in current buffer.
BEWARE: Most uses of this macro introduce bugs.
E.g. it should not be used to try and prevent some code from opening
a new window, since that window may sometimes appear in another frame,
in which case `save-window-excursion' cannot help."
(declare (indent 0) (debug t))
(let ((c (make-symbol "wconfig")))
`(let ((,c (current-window-configuration)))
(unwind-protect (progn ,@body)
(set-window-configuration ,c)))))
(defmacro with-output-to-temp-buffer (bufname &rest body)
"Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
This construct makes buffer BUFNAME empty before running BODY.
It does not make the buffer current for BODY.
Instead it binds `standard-output' to that buffer, so that output
generated with `prin1' and similar functions in BODY goes into
the buffer.
At the end of BODY, this marks buffer BUFNAME unmodifed and displays
it in a window, but does not select it. The normal way to do this is
by calling `display-buffer', then running `temp-buffer-show-hook'.
However, if `temp-buffer-show-function' is non-nil, it calls that
function instead (and does not run `temp-buffer-show-hook'). The
function gets one argument, the buffer to display.
The return value of `with-output-to-temp-buffer' is the value of the
last form in BODY. If BODY does not finish normally, the buffer
BUFNAME is not displayed.
This runs the hook `temp-buffer-setup-hook' before BODY,
with the buffer BUFNAME temporarily current. It runs the hook
`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
buffer temporarily current, and the window that was used to display it
temporarily selected. But it doesn't run `temp-buffer-show-hook'
if it uses `temp-buffer-show-function'."
(let ((old-dir (make-symbol "old-dir"))
(buf (make-symbol "buf")))
`(let* ((,old-dir default-directory)
(,buf
(with-current-buffer (get-buffer-create ,bufname)
(prog1 (current-buffer)
(kill-all-local-variables)
;; FIXME: delete_all_overlays
(setq default-directory ,old-dir)
(setq buffer-read-only nil)
(setq buffer-file-name nil)
(setq buffer-undo-list t)
(let ((inhibit-read-only t)
(inhibit-modification-hooks t))
(erase-buffer)
(run-hooks 'temp-buffer-setup-hook)))))
(standard-output ,buf))
(prog1 (progn ,@body)
(internal-temp-output-buffer-show ,buf)))))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
The value returned is the value of the last form in BODY.

4
lisp/textmodes/bibtex-style.el
View File

@ -1,4 +1,4 @@
;;; bibtex-style.el --- Major mode for BibTeX Style files
;;; bibtex-style.el --- Major mode for BibTeX Style files -*- lexical-binding: t -*-
;; Copyright (C) 2005, 2007-2011 Free Software Foundation, Inc.
@ -141,7 +141,7 @@
(looking-at "if\\$"))
(scan-error nil))))
(save-excursion
(condition-case err
(condition-case nil
(while (progn
(backward-sexp 1)
(save-excursion (skip-chars-backward " \t{") (not (bolp)))))

2
lisp/textmodes/css-mode.el
View File

@ -1,4 +1,4 @@
;;; css-mode.el --- Major mode to edit CSS files
;;; css-mode.el --- Major mode to edit CSS files -*- lexical-binding: t -*-
;; Copyright (C) 2006-2011 Free Software Foundation, Inc.

2
lisp/uniquify.el
View File

@ -1,4 +1,4 @@
;;; uniquify.el --- unique buffer names dependent on file name
;;; uniquify.el --- unique buffer names dependent on file name -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1995-1997, 2001-2011 Free Software Foundation, Inc.

42
lisp/vc/cvs-status.el
View File

@ -1,4 +1,4 @@
;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
@ -87,6 +87,12 @@
'(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
(defvar cvs-minor-wrap-function)
(defvar cvs-force-command)
(defvar cvs-minor-current-files)
(defvar cvs-secondary-branch-prefix)
(defvar cvs-branch-prefix)
(defvar cvs-tag-print-rev)
(put 'cvs-status-mode 'mode-class 'special)
;;;###autoload
(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
@ -472,7 +478,7 @@ Optional prefix ARG chooses between two representations."
(nprev (if (and cvs-tree-nomerge next
(equal vlist (cvs-tag->vlist next)))
prev vlist)))
(cvs-map (lambda (v p) v) nprev prev)))
(cvs-map (lambda (v _p) v) nprev prev)))
(after (save-excursion
(newline)
(cvs-tree-tags-insert (cdr tags) nprev)))
@ -512,24 +518,24 @@ Optional prefix ARG chooses between two representations."
;;;; Merged trees from different files
;;;;
(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
)
;; (defun cvs-tree-fuzzy-merge-1 (trees tree prev)
;; )
(defun cvs-tree-fuzzy-merge (trees tree)
"Do the impossible: merge TREE into TREES."
())
;; (defun cvs-tree-fuzzy-merge (trees tree)
;; "Do the impossible: merge TREE into TREES."
;; ())
(defun cvs-tree ()
"Get tags from the status output and merge tham all into a big tree."
(save-excursion
(goto-char (point-min))
(let ((inhibit-read-only t)
(trees (make-vector 31 0)) tree)
(while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
(cvs-tree-fuzzy-merge trees tree))
(erase-buffer)
(let ((cvs-tag-print-rev nil))
(cvs-tree-print tree 'cvs-tag->string 3)))))
;; (defun cvs-tree ()
;; "Get tags from the status output and merge them all into a big tree."
;; (save-excursion
;; (goto-char (point-min))
;; (let ((inhibit-read-only t)
;; (trees (make-vector 31 0)) tree)
;; (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
;; (cvs-tree-fuzzy-merge trees tree))
;; (erase-buffer)
;; (let ((cvs-tag-print-rev nil))
;; (cvs-tree-print tree 'cvs-tag->string 3)))))
(provide 'cvs-status)

57
lisp/vc/diff-mode.el
View File

@ -1,4 +1,4 @@
;;; diff-mode.el --- a mode for viewing/editing context diffs
;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*-
;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
@ -814,7 +814,7 @@ PREFIX is only used internally: don't use it."
(defun diff-ediff-patch ()
"Call `ediff-patch-file' on the current buffer."
(interactive)
(condition-case err
(condition-case nil
(ediff-patch-file nil (current-buffer))
(wrong-number-of-arguments (ediff-patch-file))))
@ -1171,7 +1171,7 @@ else cover the whole buffer."
;; *-change-function is asking for trouble, whereas making them
;; from a post-command-hook doesn't pose much problems
(defvar diff-unhandled-changes nil)
(defun diff-after-change-function (beg end len)
(defun diff-after-change-function (beg end _len)
"Remember to fixup the hunk header.
See `after-change-functions' for the meaning of BEG, END and LEN."
;; Ignoring changes when inhibit-read-only is set is strictly speaking
@ -1281,7 +1281,7 @@ a diff with \\[diff-reverse-direction].
(add-hook 'after-change-functions 'diff-after-change-function nil t)
(add-hook 'post-command-hook 'diff-post-command-hook nil t))
;; Neat trick from Dave Love to add more bindings in read-only mode:
(lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
(let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
(add-to-list 'minor-mode-overriding-map-alist ro-bind)
;; Turn off this little trick in case the buffer is put in view-mode.
(add-hook 'view-mode-hook
@ -1693,7 +1693,7 @@ With a prefix argument, REVERSE the hunk."
"See whether it's possible to apply the current hunk.
With a prefix argument, try to REVERSE the hunk."
(interactive "P")
(destructuring-bind (buf line-offset pos src dst &optional switched)
(destructuring-bind (buf line-offset pos src _dst &optional switched)
(diff-find-source-location nil reverse)
(set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
(diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
@ -1713,7 +1713,7 @@ then `diff-jump-to-old-file' is also set, for the next invocations."
;; This is a convenient detail when using smerge-diff.
(if event (posn-set-point (event-end event)))
(let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
(destructuring-bind (buf line-offset pos src dst &optional switched)
(destructuring-bind (buf line-offset pos src _dst &optional switched)
(diff-find-source-location other-file rev)
(pop-to-buffer buf)
(goto-char (+ (car pos) (cdr src)))
@ -1731,7 +1731,7 @@ For use in `add-log-current-defun-function'."
(when (looking-at diff-hunk-header-re)
(forward-line 1)
(re-search-forward "^[^ ]" nil t))
(destructuring-bind (&optional buf line-offset pos src dst switched)
(destructuring-bind (&optional buf _line-offset pos src dst switched)
;; Use `noprompt' since this is used in which-func-mode and such.
(ignore-errors ;Signals errors in place of prompting.
(diff-find-source-location nil nil 'noprompt))
@ -1879,28 +1879,27 @@ I.e. like `add-change-log-entry-other-window' but applied to all hunks."
;; good to call it for each change.
(save-excursion
(goto-char (point-min))
(let ((orig-buffer (current-buffer)))
(condition-case nil
;; Call add-change-log-entry-other-window for each hunk in
;; the diff buffer.
(while (progn
(diff-hunk-next)
;; Move to where the changes are,
;; `add-change-log-entry-other-window' works better in
;; that case.
(re-search-forward
(concat "\n[!+-<>]"
;; If the hunk is a context hunk with an empty first
;; half, recognize the "--- NNN,MMM ----" line
"\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
;; and skip to the next non-context line.
"\\( .*\n\\)*[+]\\)?")
nil t))
(save-excursion
;; FIXME: this pops up windows of all the buffers.
(add-change-log-entry nil nil t nil t)))
;; When there's no more hunks, diff-hunk-next signals an error.
(error nil)))))
(condition-case nil
;; Call add-change-log-entry-other-window for each hunk in
;; the diff buffer.
(while (progn
(diff-hunk-next)
;; Move to where the changes are,
;; `add-change-log-entry-other-window' works better in
;; that case.
(re-search-forward
(concat "\n[!+-<>]"
;; If the hunk is a context hunk with an empty first
;; half, recognize the "--- NNN,MMM ----" line
"\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
;; and skip to the next non-context line.
"\\( .*\n\\)*[+]\\)?")
nil t))
(save-excursion
;; FIXME: this pops up windows of all the buffers.
(add-change-log-entry nil nil t nil t)))
;; When there's no more hunks, diff-hunk-next signals an error.
(error nil))))
;; provide the package
(provide 'diff-mode)

6
lisp/vc/log-edit.el
View File

@ -1,4 +1,4 @@
;;; log-edit.el --- Major mode for editing CVS commit messages
;;; log-edit.el --- Major mode for editing CVS commit messages -*- lexical-binding: t -*-
;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
@ -329,7 +329,7 @@ automatically."
(defconst log-edit-header-contents-regexp
"[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
(defun log-edit-match-to-eoh (limit)
(defun log-edit-match-to-eoh (_limit)
;; FIXME: copied from message-match-to-eoh.
(let ((start (point)))
(rfc822-goto-eoh)
@ -361,7 +361,7 @@ automatically."
nil lax)))))
;;;###autoload
(defun log-edit (callback &optional setup params buffer mode &rest ignore)
(defun log-edit (callback &optional setup params buffer mode &rest _ignore)
"Setup a buffer to enter a log message.
\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
if MODE is nil.

3
lisp/vc/log-view.el
View File

@ -1,4 +1,4 @@
;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output
;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output -*- lexical-binding: t -*-
;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
@ -115,6 +115,7 @@
(autoload 'vc-diff-internal "vc")
(defvar cvs-minor-wrap-function)
(defvar cvs-force-command)
(defgroup log-view nil
"Major mode for browsing log output of RCS/CVS/SCCS."

2
lisp/vc/smerge-mode.el
View File

@ -1,4 +1,4 @@
;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts
;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -*- lexical-binding: t -*-
;; Copyright (C) 1999-2011 Free Software Foundation, Inc.

58
src/ChangeLog
View File

@ -1,3 +1,61 @@
2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca>
Add lexical binding.
* window.c (Ftemp_output_buffer_show): New fun.
(Fsave_window_excursion):
* print.c (Fwith_output_to_temp_buffer): Move to subr.el.
* lread.c (lisp_file_lexically_bound_p): New function.
(Fload): Bind Qlexical_binding.
(readevalloop): Remove `evalfun' arg.
Bind Qinternal_interpreter_environment.
(Feval_buffer): Bind Qlexical_binding.
(defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard):
Mark as dynamic.
(syms_of_lread): Declare `lexical-binding'.
* lisp.h (struct Lisp_Symbol): New field `declared_special'.
* keyboard.c (eval_dyn): New fun.
(menu_item_eval_property): Use it.
* image.c (parse_image_spec): Use Ffunctionp.
* fns.c (concat, mapcar1): Accept byte-code-functions.
* eval.c (Fsetq): Handle lexical vars.
(Fdefun, Fdefmacro, Ffunction): Make closures when needed.
(Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic.
(FletX, Flet): Obey lexical binding.
(Fcommandp): Handle closures.
(Feval): New `lexical' arg.
(eval_sub): New function extracted from Feval. Use it almost
everywhere where Feval was used. Look up vars in lexical env.
Handle closures.
(Ffunctionp): Move from subr.el.
(Ffuncall): Handle closures.
(apply_lambda): Remove `eval_flags'.
(funcall_lambda): Handle closures and new byte-code-functions.
(Fspecial_variable_p): New function.
(syms_of_eval): Initialize the Vinternal_interpreter_environment var,
but without exporting it to Lisp.
* doc.c (Fdocumentation, store_function_docstring):
* data.c (Finteractive_form): Handle closures.
* callint.c (Fcall_interactively): Preserve lexical-binding mode for
interactive spec.
* bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN): New
byte-codes.
(exec_byte_code): New function extracted from Fbyte_code to handle new
calling convention for byte-code-functions. Add new byte-codes.
* buffer.c (defvar_per_buffer): Set new `declared_special' field.
* alloc.c (Fmake_symbol): Init new `declared_special' field.
2011-03-31 Juanma Barranquero <lekktu@gmail.com>
* xdisp.c (redisplay_internal): Fix prototype.

14
src/alloc.c
View File

@ -2940,10 +2940,19 @@ usage: (vector &rest OBJECTS) */)
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
The arguments should be the arglist, bytecode-string, constant vector,
stack size, (optional) doc string, and (optional) interactive spec.
The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
and (optional) INTERACTIVE-SPEC.
The first four arguments are required; at most six have any
significance.
The ARGLIST can be either like the one of `lambda', in which case the arguments
will be dynamically bound before executing the byte code, or it can be an
integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
argument to catch the left-over arguments. If such an integer is used, the
arguments will not be dynamically bound but will be instead pushed on the
stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
(register size_t nargs, Lisp_Object *args)
{
@ -3071,6 +3080,7 @@ Its value and function definition are void, and its property list is nil. */)
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
p->declared_special = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;

1
src/buffer.c
View File

@ -5240,6 +5240,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring,
bo_fwd->type = Lisp_Fwd_Buffer_Obj;
bo_fwd->offset = offset;
bo_fwd->slottype = type;
sym->declared_special = 1;
sym->redirect = SYMBOL_FORWARDED;
{
/* I tried to do the job without a cast, but it seems impossible.

163
src/bytecode.c
View File

@ -80,9 +80,11 @@ Lisp_Object Qbyte_code_meter;
Lisp_Object Qbytecode;
extern Lisp_Object Qand_optional, Qand_rest;
/* Byte codes: */
#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */
#define Bvarref 010
#define Bvarset 020
#define Bvarbind 030
@ -132,7 +134,7 @@ Lisp_Object Qbytecode;
#define Bpoint 0140
/* Was Bmark in v17. */
#define Bsave_current_buffer 0141
#define Bsave_current_buffer 0141 /* Obsolete. */
#define Bgoto_char 0142
#define Binsert 0143
#define Bpoint_max 0144
@ -158,7 +160,7 @@ Lisp_Object Qbytecode;
#ifdef BYTE_CODE_SAFE
#define Bset_mark 0163 /* this loser is no longer generated as of v18 */
#endif
#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */
#define Bforward_char 0165
#define Bforward_word 0166
@ -183,16 +185,16 @@ Lisp_Object Qbytecode;
#define Bdup 0211
#define Bsave_excursion 0212
#define Bsave_window_excursion 0213
#define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1. */
#define Bsave_restriction 0214
#define Bcatch 0215
#define Bunwind_protect 0216
#define Bcondition_case 0217
#define Btemp_output_buffer_setup 0220
#define Btemp_output_buffer_show 0221
#define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1. */
#define Btemp_output_buffer_show 0221 /* Obsolete since Emacs-24.1. */
#define Bunbind_all 0222
#define Bunbind_all 0222 /* Obsolete. Never used. */
#define Bset_marker 0223
#define Bmatch_beginning 0224
@ -228,6 +230,11 @@ Lisp_Object Qbytecode;
#define BconcatN 0260
#define BinsertN 0261
/* Bstack_ref is code 0. */
#define Bstack_set 0262
#define Bstack_set2 0263
#define BdiscardN 0266
#define Bconstant 0300
/* Whether to maintain a `top' and `bottom' field in the stack frame. */
@ -413,6 +420,21 @@ the second, VECTOR, a vector of constants;
the third, MAXDEPTH, the maximum stack depth used in this function.
If the third argument is incorrect, Emacs may crash. */)
(Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
{
return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
}
/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp
argument list (including &rest, &optional, etc.), and ARGS, of size
NARGS, should be a vector of the actual arguments. The arguments in
ARGS are pushed on the stack according to ARGS_TEMPLATE before
executing BYTESTR. */
Lisp_Object
exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object args_template, int nargs, Lisp_Object *args)
{
int count = SPECPDL_INDEX ();
#ifdef BYTE_CODE_METER
@ -473,6 +495,52 @@ If the third argument is incorrect, Emacs may crash. */)
stacke = stack.bottom - 1 + XFASTINT (maxdepth);
#endif
if (INTEGERP (args_template))
{
int at = XINT (args_template);
int rest = at & 128;
int mandatory = at & 127;
int nonrest = at >> 8;
eassert (mandatory <= nonrest);
if (nargs <= nonrest)
{
int i;
for (i = 0 ; i < nargs; i++, args++)
PUSH (*args);
if (nargs < mandatory)
/* Too few arguments. */
Fsignal (Qwrong_number_of_arguments,
Fcons (Fcons (make_number (mandatory),
rest ? Qand_rest : make_number (nonrest)),
Fcons (make_number (nargs), Qnil)));
else
{
for (; i < nonrest; i++)
PUSH (Qnil);
if (rest)
PUSH (Qnil);
}
}
else if (rest)
{
int i;
for (i = 0 ; i < nonrest; i++, args++)
PUSH (*args);
PUSH (Flist (nargs - nonrest, args));
}
else
/* Too many arguments. */
Fsignal (Qwrong_number_of_arguments,
Fcons (Fcons (make_number (mandatory),
make_number (nonrest)),
Fcons (make_number (nargs), Qnil)));
}
else if (! NILP (args_template))
/* We should push some arguments on the stack. */
{
error ("Unknown args template!");
}
while (1)
{
#ifdef BYTE_CODE_SAFE
@ -733,7 +801,7 @@ If the third argument is incorrect, Emacs may crash. */)
AFTER_POTENTIAL_GC ();
break;
case Bunbind_all:
case Bunbind_all: /* Obsolete. Never used. */
/* To unbind back to the beginning of this frame. Not used yet,
but will be needed for tail-recursion elimination. */
BEFORE_POTENTIAL_GC ();
@ -861,37 +929,43 @@ If the third argument is incorrect, Emacs may crash. */)
save_excursion_save ());
break;
case Bsave_current_buffer:
case Bsave_current_buffer: /* Obsolete since ??. */
case Bsave_current_buffer_1:
record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
break;
case Bsave_window_excursion:
BEFORE_POTENTIAL_GC ();
TOP = Fsave_window_excursion (TOP);
AFTER_POTENTIAL_GC ();
break;
case Bsave_window_excursion: /* Obsolete since 24.1. */
{
register int count = SPECPDL_INDEX ();
record_unwind_protect (Fset_window_configuration,
Fcurrent_window_configuration (Qnil));
BEFORE_POTENTIAL_GC ();
TOP = Fprogn (TOP);
unbind_to (count, TOP);
AFTER_POTENTIAL_GC ();
break;
}
case Bsave_restriction:
record_unwind_protect (save_restriction_restore,
save_restriction_save ());
break;
case Bcatch:
case Bcatch: /* FIXME: ill-suited for lexbind */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
v1 = POP;
TOP = internal_catch (TOP, Feval, v1);
TOP = internal_catch (TOP, eval_sub, v1);
AFTER_POTENTIAL_GC ();
break;
}
case Bunwind_protect:
case Bunwind_protect: /* FIXME: avoid closure for lexbind */
record_unwind_protect (Fprogn, POP);
break;
case Bcondition_case:
case Bcondition_case: /* FIXME: ill-suited for lexbind */
{
Lisp_Object handlers, body;
handlers = POP;
@ -902,7 +976,7 @@ If the third argument is incorrect, Emacs may crash. */)
break;
}
case Btemp_output_buffer_setup:
case Btemp_output_buffer_setup: /* Obsolete since 24.1. */
BEFORE_POTENTIAL_GC ();
CHECK_STRING (TOP);
temp_output_buffer_setup (SSDATA (TOP));
@ -910,7 +984,7 @@ If the third argument is incorrect, Emacs may crash. */)
TOP = Vstandard_output;
break;
case Btemp_output_buffer_show:
case Btemp_output_buffer_show: /* Obsolete since 24.1. */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
@ -1382,7 +1456,7 @@ If the third argument is incorrect, Emacs may crash. */)
AFTER_POTENTIAL_GC ();
break;
case Binteractive_p:
case Binteractive_p: /* Obsolete since 24.1. */
PUSH (Finteractive_p ());
break;
@ -1672,8 +1746,57 @@ If the third argument is incorrect, Emacs may crash. */)
#endif
case 0:
/* Actually this is Bstack_ref with offset 0, but we use Bdup
for that instead. */
/* case Bstack_ref: */
abort ();
/* Handy byte-codes for lexical binding. */
case Bstack_ref+1:
case Bstack_ref+2:
case Bstack_ref+3:
case Bstack_ref+4:
case Bstack_ref+5:
{
Lisp_Object *ptr = top - (op - Bstack_ref);
PUSH (*ptr);
break;
}
case Bstack_ref+6:
{
Lisp_Object *ptr = top - (FETCH);
PUSH (*ptr);
break;
}
case Bstack_ref+7:
{
Lisp_Object *ptr = top - (FETCH2);
PUSH (*ptr);
break;
}
/* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
case Bstack_set:
{
Lisp_Object *ptr = top - (FETCH);
*ptr = POP;
break;
}
case Bstack_set2:
{
Lisp_Object *ptr = top - (FETCH2);
*ptr = POP;
break;
}
case BdiscardN:
op = FETCH;
if (op & 0x80)
{
op &= 0x7F;
top[-op] = TOP;
}
DISCARD (op);
break;
case 255:
default:
#ifdef BYTE_CODE_SAFE

13
src/callint.c
View File

@ -121,8 +121,9 @@ usage: (interactive &optional ARGS) */)
static Lisp_Object
quotify_arg (register Lisp_Object exp)
{
if (!INTEGERP (exp) && !STRINGP (exp)
&& !NILP (exp) && !EQ (exp, Qt))
if (CONSP (exp)
|| (SYMBOLP (exp)
&& !NILP (exp) && !EQ (exp, Qt)))
return Fcons (Qquote, Fcons (exp, Qnil));
return exp;
@ -169,6 +170,9 @@ check_mark (int for_region)
static void
fix_command (Lisp_Object input, Lisp_Object values)
{
/* FIXME: Instead of this ugly hack, we should provide a way for an
interactive spec to return an expression/function that will re-build the
args without user intervention. */
if (CONSP (input))
{
Lisp_Object car;
@ -332,11 +336,14 @@ invoke it. If KEYS is omitted or nil, the return value of
else
{
Lisp_Object input;
Lisp_Object funval = Findirect_function (function, Qt);
i = num_input_events;
input = specs;
/* Compute the arg values using the user's expression. */
GCPRO2 (input, filter_specs);
specs = Feval (specs);
specs = Feval (specs,
CONSP (funval) && EQ (Qclosure, XCAR (funval))
? Qt : Qnil);
UNGCPRO;
if (i != num_input_events || !NILP (record_flag))
{

8
src/data.c
View File

@ -745,7 +745,9 @@ Value, if non-nil, is a list \(interactive SPEC). */)
else if (CONSP (fun))
{
Lisp_Object funcar = XCAR (fun);
if (EQ (funcar, Qlambda))
if (EQ (funcar, Qclosure))
return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
else if (EQ (funcar, Qlambda))
return Fassq (Qinteractive, Fcdr (XCDR (fun)));
else if (EQ (funcar, Qautoload))
{
@ -1431,7 +1433,7 @@ usage: (setq-default [VAR VALUE]...) */)
do
{
val = Feval (Fcar (Fcdr (args_left)));
val = eval_sub (Fcar (Fcdr (args_left)));
symbol = XCAR (args_left);
Fset_default (symbol, val);
args_left = Fcdr (XCDR (args_left));
@ -2101,7 +2103,7 @@ or a byte-code object. IDX starts at 0. */)
if (idxval < 0 || idxval >= size)
args_out_of_range (array, idx);
return XVECTOR (array)->contents[idxval];
return AREF (array, idxval);
}
}

7
src/doc.c
View File

@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
Lisp_Object Qfunction_documentation;
extern Lisp_Object Qclosure;
/* Buffer used for reading from documentation file. */
static char *get_doc_string_buffer;
static int get_doc_string_buffer_size;
@ -374,6 +375,7 @@ string is passed through `substitute-command-keys'. */)
else if (EQ (funcar, Qkeymap))
return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
else if (EQ (funcar, Qlambda)
|| (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
|| EQ (funcar, Qautoload))
{
Lisp_Object tem1 = Fcdr (Fcdr (fun));
@ -480,7 +482,7 @@ aren't strings. */)
}
else if (!STRINGP (tem))
/* Feval protects its argument. */
tem = Feval (tem);
tem = Feval (tem, Qnil);
if (NILP (raw) && STRINGP (tem))
tem = Fsubstitute_command_keys (tem);
@ -507,7 +509,8 @@ store_function_docstring (Lisp_Object fun, EMACS_INT offset)
Lisp_Object tem;
tem = XCAR (fun);
if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
|| (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
{
tem = Fcdr (Fcdr (fun));
if (CONSP (tem) && INTEGERP (XCAR (tem)))

384
src/eval.c
View File

@ -64,6 +64,8 @@ Lisp_Object Qinhibit_quit;
Lisp_Object Qand_rest, Qand_optional;
Lisp_Object Qdebug_on_error;
Lisp_Object Qdeclare;
Lisp_Object Qinternal_interpreter_environment, Qclosure;
Lisp_Object Qdebug;
/* This holds either the symbol `run-hooks' or nil.
@ -115,10 +117,10 @@ Lisp_Object Vsignaling_function;
int handling_signal;
static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object*);
static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object *);
static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;
static int interactive_p (int);
static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int);
static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
void
init_eval_once (void)
@ -127,7 +129,7 @@ init_eval_once (void)
specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
specpdl_ptr = specpdl;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1000;
max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
max_lisp_eval_depth = 600;
Vrun_hooks = Qnil;
@ -244,7 +246,7 @@ usage: (or CONDITIONS...) */)
while (CONSP (args))
{
val = Feval (XCAR (args));
val = eval_sub (XCAR (args));
if (!NILP (val))
break;
args = XCDR (args);
@ -268,7 +270,7 @@ usage: (and CONDITIONS...) */)
while (CONSP (args))
{
val = Feval (XCAR (args));
val = eval_sub (XCAR (args));
if (NILP (val))
break;
args = XCDR (args);
@ -290,11 +292,11 @@ usage: (if COND THEN ELSE...) */)
struct gcpro gcpro1;
GCPRO1 (args);
cond = Feval (Fcar (args));
cond = eval_sub (Fcar (args));
UNGCPRO;
if (!NILP (cond))
return Feval (Fcar (Fcdr (args)));
return eval_sub (Fcar (Fcdr (args)));
return Fprogn (Fcdr (Fcdr (args)));
}
@ -318,7 +320,7 @@ usage: (cond CLAUSES...) */)
while (!NILP (args))
{
clause = Fcar (args);
val = Feval (Fcar (clause));
val = eval_sub (Fcar (clause));
if (!NILP (val))
{
if (!EQ (XCDR (clause), Qnil))
@ -344,7 +346,7 @@ usage: (progn BODY...) */)
while (CONSP (args))
{
val = Feval (XCAR (args));
val = eval_sub (XCAR (args));
args = XCDR (args);
}
@ -373,13 +375,12 @@ usage: (prog1 FIRST BODY...) */)
do
{
Lisp_Object tem = eval_sub (XCAR (args_left));
if (!(argnum++))
val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
val = tem;
args_left = XCDR (args_left);
}
while (!NILP(args_left));
while (CONSP (args_left));
UNGCPRO;
return val;
@ -408,13 +409,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */)
do
{
Lisp_Object tem = eval_sub (XCAR (args_left));
if (!(argnum++))
val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
val = tem;
args_left = XCDR (args_left);
}
while (!NILP (args_left));
while (CONSP (args_left));
UNGCPRO;
return val;
@ -432,7 +432,7 @@ usage: (setq [SYM VAL]...) */)
(Lisp_Object args)
{
register Lisp_Object args_left;
register Lisp_Object val, sym;
register Lisp_Object val, sym, lex_binding;
struct gcpro gcpro1;
if (NILP (args))
@ -443,9 +443,19 @@ usage: (setq [SYM VAL]...) */)
do
{
val = Feval (Fcar (Fcdr (args_left)));
val = eval_sub (Fcar (Fcdr (args_left)));
sym = Fcar (args_left);
Fset (sym, val);
/* Like for eval_sub, we do not check declared_special here since
it's been done when let-binding. */
if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
&& SYMBOLP (sym)
&& !NILP (lex_binding
= Fassq (sym, Vinternal_interpreter_environment)))
XSETCDR (lex_binding, val); /* SYM is lexically bound. */
else
Fset (sym, val); /* SYM is dynamically bound. */
args_left = Fcdr (Fcdr (args_left));
}
while (!NILP(args_left));
@ -471,9 +481,21 @@ In byte compilation, `function' causes its argument to be compiled.
usage: (function ARG) */)
(Lisp_Object args)
{
Lisp_Object quoted = XCAR (args);
if (!NILP (Fcdr (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
return Fcar (args);
if (!NILP (Vinternal_interpreter_environment)
&& CONSP (quoted)
&& EQ (XCAR (quoted), Qlambda))
/* This is a lambda expression within a lexical environment;
return an interpreted closure instead of a simple lambda. */
return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
XCDR (quoted)));
else
/* Simply quote the argument. */
return quoted;
}
@ -496,7 +518,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
use `called-interactively-p'. */)
(void)
{
return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil;
return interactive_p (1) ? Qt : Qnil;
}
@ -589,6 +611,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
fn_name = Fcar (args);
CHECK_SYMBOL (fn_name);
defn = Fcons (Qlambda, Fcdr (args));
if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
defn = Ffunction (Fcons (defn, Qnil));
if (!NILP (Vpurify_flag))
defn = Fpurecopy (defn);
if (CONSP (XSYMBOL (fn_name)->function)
@ -660,7 +684,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
tail = Fcons (lambda_list, tail);
else
tail = Fcons (lambda_list, Fcons (doc, tail));
defn = Fcons (Qmacro, Fcons (Qlambda, tail));
defn = Fcons (Qlambda, tail);
if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
defn = Ffunction (Fcons (defn, Qnil));
defn = Fcons (Qmacro, defn);
if (!NILP (Vpurify_flag))
defn = Fpurecopy (defn);
@ -720,6 +748,7 @@ The return value is BASE-VARIABLE. */)
error ("Don't know how to make a let-bound variable an alias");
}
sym->declared_special = 1;
sym->redirect = SYMBOL_VARALIAS;
SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
sym->constant = SYMBOL_CONSTANT_P (base_variable);
@ -765,6 +794,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
tem = Fdefault_boundp (sym);
if (!NILP (tail))
{
/* Do it before evaluating the initial value, for self-references. */
XSYMBOL (sym)->declared_special = 1;
if (SYMBOL_CONSTANT_P (sym))
{
/* For upward compatibility, allow (defvar :foo (quote :foo)). */
@ -778,7 +810,7 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
}
if (NILP (tem))
Fset_default (sym, Feval (Fcar (tail)));
Fset_default (sym, eval_sub (Fcar (tail)));
else
{ /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */
@ -804,6 +836,13 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
}
LOADHIST_ATTACH (sym);
}
else if (!NILP (Vinternal_interpreter_environment)
&& !XSYMBOL (sym)->declared_special)
/* A simple (defvar foo) with lexical scoping does "nothing" except
declare that var to be dynamically scoped *locally* (i.e. within
the current file or let-block). */
Vinternal_interpreter_environment =
Fcons (sym, Vinternal_interpreter_environment);
else
{
/* Simple (defvar <var>) should not count as a definition at all.
@ -834,10 +873,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
error ("Too many arguments");
tem = Feval (Fcar (Fcdr (args)));
tem = eval_sub (Fcar (Fcdr (args)));
if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fset_default (sym, tem);
XSYMBOL (sym)->declared_special = 1;
tem = Fcar (Fcdr (Fcdr (args)));
if (!NILP (tem))
{
@ -924,27 +964,53 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.
usage: (let* VARLIST BODY...) */)
(Lisp_Object args)
{
Lisp_Object varlist, val, elt;
Lisp_Object varlist, var, val, elt, lexenv;
int count = SPECPDL_INDEX ();
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (args, elt, varlist);
lexenv = Vinternal_interpreter_environment;
varlist = Fcar (args);
while (!NILP (varlist))
while (CONSP (varlist))
{
QUIT;
elt = Fcar (varlist);
elt = XCAR (varlist);
if (SYMBOLP (elt))
specbind (elt, Qnil);
{
var = elt;
val = Qnil;
}
else if (! NILP (Fcdr (Fcdr (elt))))
signal_error ("`let' bindings can have only one value-form", elt);
else
{
val = Feval (Fcar (Fcdr (elt)));
specbind (Fcar (elt), val);
var = Fcar (elt);
val = eval_sub (Fcar (Fcdr (elt)));
}
varlist = Fcdr (varlist);
if (!NILP (lexenv) && SYMBOLP (var)
&& !XSYMBOL (var)->declared_special
&& NILP (Fmemq (var, Vinternal_interpreter_environment)))
/* Lexically bind VAR by adding it to the interpreter's binding
alist. */
{
Lisp_Object newenv
= Fcons (Fcons (var, val), Vinternal_interpreter_environment);
if (EQ (Vinternal_interpreter_environment, lexenv))
/* Save the old lexical environment on the specpdl stack,
but only for the first lexical binding, since we'll never
need to revert to one of the intermediate ones. */
specbind (Qinternal_interpreter_environment, newenv);
else
Vinternal_interpreter_environment = newenv;
}
else
specbind (var, val);
varlist = XCDR (varlist);
}
UNGCPRO;
val = Fprogn (Fcdr (args));
@ -960,7 +1026,7 @@ All the VALUEFORMs are evalled before any symbols are bound.
usage: (let VARLIST BODY...) */)
(Lisp_Object args)
{
Lisp_Object *temps, tem;
Lisp_Object *temps, tem, lexenv;
register Lisp_Object elt, varlist;
int count = SPECPDL_INDEX ();
register size_t argnum;
@ -987,22 +1053,36 @@ usage: (let VARLIST BODY...) */)
else if (! NILP (Fcdr (Fcdr (elt))))
signal_error ("`let' bindings can have only one value-form", elt);
else
temps [argnum++] = Feval (Fcar (Fcdr (elt)));
temps [argnum++] = eval_sub (Fcar (Fcdr (elt)));
gcpro2.nvars = argnum;
}
UNGCPRO;
lexenv = Vinternal_interpreter_environment;
varlist = Fcar (args);
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
{
Lisp_Object var;
elt = XCAR (varlist);
var = SYMBOLP (elt) ? elt : Fcar (elt);
tem = temps[argnum++];
if (SYMBOLP (elt))
specbind (elt, tem);
if (!NILP (lexenv) && SYMBOLP (var)
&& !XSYMBOL (var)->declared_special
&& NILP (Fmemq (var, Vinternal_interpreter_environment)))
/* Lexically bind VAR by adding it to the lexenv alist. */
lexenv = Fcons (Fcons (var, tem), lexenv);
else
specbind (Fcar (elt), tem);
/* Dynamically bind VAR. */
specbind (var, tem);
}
if (!EQ (lexenv, Vinternal_interpreter_environment))
/* Instantiate a new lexical environment. */
specbind (Qinternal_interpreter_environment, lexenv);
elt = Fprogn (Fcdr (args));
SAFE_FREE ();
return unbind_to (count, elt);
@ -1022,7 +1102,7 @@ usage: (while TEST BODY...) */)
test = Fcar (args);
body = Fcdr (args);
while (!NILP (Feval (test)))
while (!NILP (eval_sub (test)))
{
QUIT;
Fprogn (body);
@ -1124,7 +1204,7 @@ usage: (catch TAG BODY...) */)
struct gcpro gcpro1;
GCPRO1 (args);
tag = Feval (Fcar (args));
tag = eval_sub (Fcar (args));
UNGCPRO;
return internal_catch (tag, Fprogn, Fcdr (args));
}
@ -1254,7 +1334,7 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
int count = SPECPDL_INDEX ();
record_unwind_protect (Fprogn, Fcdr (args));
val = Feval (Fcar (args));
val = eval_sub (Fcar (args));
return unbind_to (count, val);
}
@ -1355,7 +1435,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
h.tag = &c;
handlerlist = &h;
val = Feval (bodyform);
val = eval_sub (bodyform);
catchlist = c.next;
handlerlist = h.next;
return val;
@ -1999,9 +2079,12 @@ then strings and vectors are not accepted. */)
if (!CONSP (fun))
return Qnil;
funcar = XCAR (fun);
if (EQ (funcar, Qlambda))
if (EQ (funcar, Qclosure))
return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
? Qt : if_prop);
else if (EQ (funcar, Qlambda))
return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
if (EQ (funcar, Qautoload))
else if (EQ (funcar, Qautoload))
return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
else
return Qnil;
@ -2119,9 +2202,21 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname)
}
DEFUN ("eval", Feval, Seval, 1, 1, 0,
doc: /* Evaluate FORM and return its value. */)
(Lisp_Object form)
DEFUN ("eval", Feval, Seval, 1, 2, 0,
doc: /* Evaluate FORM and return its value.
If LEXICAL is t, evaluate using lexical scoping. */)
(Lisp_Object form, Lisp_Object lexical)
{
int count = SPECPDL_INDEX ();
specbind (Qinternal_interpreter_environment,
NILP (lexical) ? Qnil : Fcons (Qt, Qnil));
return unbind_to (count, eval_sub (form));
}
/* Eval a sub-expression of the current expression (i.e. in the same
lexical scope). */
Lisp_Object
eval_sub (Lisp_Object form)
{
Lisp_Object fun, val, original_fun, original_args;
Lisp_Object funcar;
@ -2132,7 +2227,20 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
abort ();
if (SYMBOLP (form))
return Fsymbol_value (form);
{
/* Look up its binding in the lexical environment.
We do not pay attention to the declared_special flag here, since we
already did that when let-binding the variable. */
Lisp_Object lex_binding
= !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
? Fassq (form, Vinternal_interpreter_environment)
: Qnil;
if (CONSP (lex_binding))
return XCDR (lex_binding);
else
return Fsymbol_value (form);
}
if (!CONSP (form))
return form;
@ -2216,7 +2324,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
while (!NILP (args_left))
{
vals[argnum++] = Feval (Fcar (args_left));
vals[argnum++] = eval_sub (Fcar (args_left));
args_left = Fcdr (args_left);
gcpro3.nvars = argnum;
}
@ -2237,7 +2345,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
maxargs = XSUBR (fun)->max_args;
for (i = 0; i < maxargs; args_left = Fcdr (args_left))
{
argvals[i] = Feval (Fcar (args_left));
argvals[i] = eval_sub (Fcar (args_left));
gcpro3.nvars = ++i;
}
@ -2297,7 +2405,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
}
}
else if (COMPILEDP (fun))
val = apply_lambda (fun, original_args, 1);
val = apply_lambda (fun, original_args);
else
{
if (EQ (fun, Qunbound))
@ -2313,9 +2421,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
goto retry;
}
if (EQ (funcar, Qmacro))
val = Feval (apply1 (Fcdr (fun), original_args));
else if (EQ (funcar, Qlambda))
val = apply_lambda (fun, original_args, 1);
val = eval_sub (apply1 (Fcdr (fun), original_args));
else if (EQ (funcar, Qlambda)
|| EQ (funcar, Qclosure))
val = apply_lambda (fun, original_args);
else
xsignal1 (Qinvalid_function, original_fun);
}
@ -2786,6 +2895,39 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
/* The caller should GCPRO all the elements of ARGS. */
DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
doc: /* Non-nil if OBJECT is a function. */)
(Lisp_Object object)
{
if (SYMBOLP (object) && !NILP (Ffboundp (object)))
{
object = Findirect_function (object, Qt);
if (CONSP (object) && EQ (XCAR (object), Qautoload))
{
/* Autoloaded symbols are functions, except if they load
macros or keymaps. */
int i;
for (i = 0; i < 4 && CONSP (object); i++)
object = XCDR (object);
return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt;
}
}
if (SUBRP (object))
return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil;
else if (COMPILEDP (object))
return Qt;
else if (CONSP (object))
{
Lisp_Object car = XCAR (object);
return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil;
}
else
return Qnil;
}
DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
doc: /* Call first argument as a function, passing remaining arguments to it.
Return the value that function returns.
@ -2930,7 +3072,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
funcar = XCAR (fun);
if (!SYMBOLP (funcar))
xsignal1 (Qinvalid_function, original_fun);
if (EQ (funcar, Qlambda))
if (EQ (funcar, Qlambda)
|| EQ (funcar, Qclosure))
val = funcall_lambda (fun, numargs, args + 1);
else if (EQ (funcar, Qautoload))
{
@ -2950,7 +3093,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
}
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag)
apply_lambda (Lisp_Object fun, Lisp_Object args)
{
Lisp_Object args_left;
size_t numargs;
@ -2970,18 +3113,15 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag)
for (i = 0; i < numargs; )
{
tem = Fcar (args_left), args_left = Fcdr (args_left);
if (eval_flag) tem = Feval (tem);
tem = eval_sub (tem);
arg_vector[i++] = tem;
gcpro1.nvars = i;
}
UNGCPRO;
if (eval_flag)
{
backtrace_list->args = arg_vector;
backtrace_list->nargs = i;
}
backtrace_list->args = arg_vector;
backtrace_list->nargs = i;
backtrace_list->evalargs = 0;
tem = funcall_lambda (fun, numargs, arg_vector);
@ -3002,13 +3142,21 @@ static Lisp_Object
funcall_lambda (Lisp_Object fun, size_t nargs,
register Lisp_Object *arg_vector)
{
Lisp_Object val, syms_left, next;
Lisp_Object val, syms_left, next, lexenv;
int count = SPECPDL_INDEX ();
size_t i;
int optional, rest;
if (CONSP (fun))
{
if (EQ (XCAR (fun), Qclosure))
{
fun = XCDR (fun); /* Drop `closure'. */
lexenv = XCAR (fun);
CHECK_LIST_CONS (fun, fun);
}
else
lexenv = Qnil;
syms_left = XCDR (fun);
if (CONSP (syms_left))
syms_left = XCAR (syms_left);
@ -3016,7 +3164,30 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
xsignal1 (Qinvalid_function, fun);
}
else if (COMPILEDP (fun))
syms_left = AREF (fun, COMPILED_ARGLIST);
{
syms_left = AREF (fun, COMPILED_ARGLIST);
if (INTEGERP (syms_left))
/* A byte-code object with a non-nil `push args' slot means we
shouldn't bind any arguments, instead just call the byte-code
interpreter directly; it will push arguments as necessary.
Byte-code objects with either a non-existant, or a nil value for
the `push args' slot (the default), have dynamically-bound
arguments, and use the argument-binding code below instead (as do
all interpreted functions, even lexically bound ones). */
{
/* If we have not actually read the bytecode string
and constants vector yet, fetch them from the file. */
if (CONSP (AREF (fun, COMPILED_BYTECODE)))
Ffetch_bytecode (fun);
return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
AREF (fun, COMPILED_CONSTANTS),
AREF (fun, COMPILED_STACK_DEPTH),
syms_left,
nargs, arg_vector);
}
lexenv = Qnil;
}
else
abort ();
@ -3033,17 +3204,29 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
rest = 1;
else if (EQ (next, Qand_optional))
optional = 1;
else if (rest)
{
specbind (next, Flist (nargs - i, &arg_vector[i]));
i = nargs;
}
else if (i < nargs)
specbind (next, arg_vector[i++]);
else if (!optional)
xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
else
specbind (next, Qnil);
{
Lisp_Object val;
if (rest)
{
val = Flist (nargs - i, &arg_vector[i]);
i = nargs;
}
else if (i < nargs)
val = arg_vector[i++];
else if (!optional)
xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
else
val = Qnil;
/* Bind the argument. */
if (!NILP (lexenv) && SYMBOLP (next))
/* Lexically bind NEXT by adding it to the lexenv alist. */
lexenv = Fcons (Fcons (next, val), lexenv);
else
/* Dynamically bind NEXT. */
specbind (next, val);
}
}
if (!NILP (syms_left))
@ -3051,6 +3234,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
else if (i < nargs)
xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
if (!EQ (lexenv, Vinternal_interpreter_environment))
/* Instantiate a new lexical environment. */
specbind (Qinternal_interpreter_environment, lexenv);
if (CONSP (fun))
val = Fprogn (XCDR (XCDR (fun)));
else
@ -3059,9 +3246,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs,
and constants vector yet, fetch them from the file. */
if (CONSP (AREF (fun, COMPILED_BYTECODE)))
Ffetch_bytecode (fun);
val = Fbyte_code (AREF (fun, COMPILED_BYTECODE),
AREF (fun, COMPILED_CONSTANTS),
AREF (fun, COMPILED_STACK_DEPTH));
val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
AREF (fun, COMPILED_CONSTANTS),
AREF (fun, COMPILED_STACK_DEPTH),
Qnil, 0, 0);
}
return unbind_to (count, val);
@ -3297,6 +3485,17 @@ unbind_to (int count, Lisp_Object value)
UNGCPRO;
return value;
}
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
doc: /* Return non-nil if SYMBOL's global binding has been declared special.
A special variable is one that will be bound dynamically, even in a
context where binding is lexical by default. */)
(Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
}
DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
@ -3437,6 +3636,8 @@ mark_backtrace (void)
}
}
EXFUN (Funintern, 2);
void
syms_of_eval (void)
{
@ -3509,6 +3710,9 @@ before making `inhibit-quit' nil. */);
Qand_optional = intern_c_string ("&optional");
staticpro (&Qand_optional);
Qclosure = intern_c_string ("closure");
staticpro (&Qclosure);
Qdebug = intern_c_string ("debug");
staticpro (&Qdebug);
@ -3576,6 +3780,28 @@ DECL is a list `(declare ...)' containing the declarations.
The value the function returns is not used. */);
Vmacro_declaration_function = Qnil;
/* When lexical binding is being used,
vinternal_interpreter_environment is non-nil, and contains an alist
of lexically-bound variable, or (t), indicating an empty
environment. The lisp name of this variable would be
`internal-interpreter-environment' if it weren't hidden.
Every element of this list can be either a cons (VAR . VAL)
specifying a lexical binding, or a single symbol VAR indicating
that this variable should use dynamic scoping. */
Qinternal_interpreter_environment
= intern_c_string ("internal-interpreter-environment");
staticpro (&Qinternal_interpreter_environment);
DEFVAR_LISP ("internal-interpreter-environment",
Vinternal_interpreter_environment,
doc: /* If non-nil, the current lexical environment of the lisp interpreter.
When lexical binding is not being used, this variable is nil.
A value of `(t)' indicates an empty environment, otherwise it is an
alist of active lexical bindings. */);
Vinternal_interpreter_environment = Qnil;
/* Don't export this variable to Elisp, so noone can mess with it
(Just imagine if someone makes it buffer-local). */
Funintern (Qinternal_interpreter_environment, Qnil);
Vrun_hooks = intern_c_string ("run-hooks");
staticpro (&Vrun_hooks);
@ -3625,4 +3851,6 @@ The value the function returns is not used. */);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
defsubr (&Sspecial_variable_p);
defsubr (&Sfunctionp);
}

4
src/fns.c
View File

@ -510,7 +510,7 @@ concat (size_t nargs, Lisp_Object *args,
Lisp_Object ch;
EMACS_INT this_len_byte;
if (VECTORP (this))
if (VECTORP (this) || COMPILEDP (this))
for (i = 0; i < len; i++)
{
ch = AREF (this, i);
@ -2297,7 +2297,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
1) lists are not relocated and 2) the list is marked via `seq' so will not
be freed */
if (VECTORP (seq))
if (VECTORP (seq) || COMPILEDP (seq))
{
for (i = 0; i < leni; i++)
{

4
src/image.c
View File

@ -831,9 +831,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
case IMAGE_FUNCTION_VALUE:
value = indirect_function (value);
if (SUBRP (value)
|| COMPILEDP (value)
|| (CONSP (value) && EQ (XCAR (value), Qlambda)))
if (!NILP (Ffunctionp (value)))
break;
return 0;

12
src/keyboard.c
View File

@ -1134,7 +1134,7 @@ command_loop_2 (Lisp_Object ignore)
static Lisp_Object
top_level_2 (void)
{
return Feval (Vtop_level);
return Feval (Vtop_level, Qnil);
}
Lisp_Object
@ -3095,7 +3095,7 @@ read_char (int commandflag, int nmaps, Lisp_Object *maps, Lisp_Object prev_event
help_form_saved_window_configs);
record_unwind_protect (read_char_help_form_unwind, Qnil);
tem0 = Feval (Vhelp_form);
tem0 = Feval (Vhelp_form, Qnil);
if (STRINGP (tem0))
internal_with_output_to_temp_buffer ("*Help*", print_help, tem0);
@ -7571,6 +7571,12 @@ menu_item_eval_property_1 (Lisp_Object arg)
return Qnil;
}
static Lisp_Object
eval_dyn (Lisp_Object form)
{
return Feval (form, Qnil);
}
/* Evaluate an expression and return the result (or nil if something
went wrong). Used to evaluate dynamic parts of menu items. */
Lisp_Object
@ -7579,7 +7585,7 @@ menu_item_eval_property (Lisp_Object sexpr)
int count = SPECPDL_INDEX ();
Lisp_Object val;
specbind (Qinhibit_redisplay, Qt);
val = internal_condition_case_1 (Feval, sexpr, Qerror,
val = internal_condition_case_1 (eval_dyn, sexpr, Qerror,
menu_item_eval_property_1);
return unbind_to (count, val);
}

12
src/lisp.h
View File

@ -1016,6 +1016,10 @@ struct Lisp_Symbol
/* Interned state of the symbol. This is an enumerator from
enum symbol_interned. */
unsigned interned : 2;
/* Non-zero means that this variable has been explicitly declared
special (with `defvar' etc), and shouldn't be lexically bound. */
unsigned declared_special : 1;
/* The symbol's name, as a Lisp string.
@ -2814,7 +2818,7 @@ extern void syms_of_lread (void);
/* Defined in eval.c. */
extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro;
extern Lisp_Object Qinhibit_quit;
extern Lisp_Object Qinhibit_quit, Qclosure;
extern Lisp_Object Vautoload_queue;
extern Lisp_Object Vsignaling_function;
extern int handling_signal;
@ -2844,7 +2848,9 @@ extern void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN;
extern void signal_error (const char *, Lisp_Object) NO_RETURN;
EXFUN (Fcommandp, 2);
EXFUN (Feval, 1);
EXFUN (Ffunctionp, 1);
EXFUN (Feval, 2);
extern Lisp_Object eval_sub (Lisp_Object form);
EXFUN (Fapply, MANY);
EXFUN (Ffuncall, MANY);
EXFUN (Fbacktrace, 0);
@ -3264,6 +3270,8 @@ extern struct byte_stack *byte_stack_list;
extern void mark_byte_stack (void);
#endif
extern void unmark_byte_stack (void);
extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, int, Lisp_Object *);
/* Defined in macros.c */
extern Lisp_Object Qexecute_kbd_macro;

162
src/lread.c
View File

@ -73,6 +73,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name;
Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
Lisp_Object Qinhibit_file_name_operation;
Lisp_Object Qeval_buffer_list;
Lisp_Object Qlexical_binding;
Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
/* Used instead of Qget_file_char while loading *.elc files compiled
@ -81,6 +82,8 @@ static Lisp_Object Qget_emacs_mule_file_char;
static Lisp_Object Qload_force_doc_strings;
extern Lisp_Object Qinternal_interpreter_environment;
static Lisp_Object Qload_in_progress;
/* The association list of objects read with the #n=object form.
@ -147,8 +150,7 @@ static Lisp_Object Vloads_in_progress;
static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
Lisp_Object);
static void readevalloop (Lisp_Object, FILE*, Lisp_Object,
Lisp_Object (*) (Lisp_Object), int,
static void readevalloop (Lisp_Object, FILE*, Lisp_Object, int,
Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
static Lisp_Object load_unwind (Lisp_Object);
@ -768,6 +770,116 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
}
/* Return true if the lisp code read using READCHARFUN defines a non-nil
`lexical-binding' file variable. After returning, the stream is
positioned following the first line, if it is a comment, otherwise
nothing is read. */
static int
lisp_file_lexically_bound_p (Lisp_Object readcharfun)
{
int ch = READCHAR;
if (ch != ';')
/* The first line isn't a comment, just give up. */
{
UNREAD (ch);
return 0;
}
else
/* Look for an appropriate file-variable in the first line. */
{
int rv = 0;
enum {
NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX,
} beg_end_state = NOMINAL;
int in_file_vars = 0;
#define UPDATE_BEG_END_STATE(ch) \
if (beg_end_state == NOMINAL) \
beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
else if (beg_end_state == AFTER_FIRST_DASH) \
beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
else if (beg_end_state == AFTER_ASTERIX) \
{ \
if (ch == '-') \
in_file_vars = !in_file_vars; \
beg_end_state = NOMINAL; \
}
/* Skip until we get to the file vars, if any. */
do
{
ch = READCHAR;
UPDATE_BEG_END_STATE (ch);
}
while (!in_file_vars && ch != '\n' && ch != EOF);
while (in_file_vars)
{
char var[100], *var_end, val[100], *val_end;
ch = READCHAR;
/* Read a variable name. */
while (ch == ' ' || ch == '\t')
ch = READCHAR;
var_end = var;
while (ch != ':' && ch != '\n' && ch != EOF)
{
if (var_end < var + sizeof var - 1)
*var_end++ = ch;
UPDATE_BEG_END_STATE (ch);
ch = READCHAR;
}
while (var_end > var
&& (var_end[-1] == ' ' || var_end[-1] == '\t'))
var_end--;
*var_end = '\0';
if (ch == ':')
{
/* Read a variable value. */
ch = READCHAR;
while (ch == ' ' || ch == '\t')
ch = READCHAR;
val_end = val;
while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
{
if (val_end < val + sizeof val - 1)
*val_end++ = ch;
UPDATE_BEG_END_STATE (ch);
ch = READCHAR;
}
if (! in_file_vars)
/* The value was terminated by an end-marker, which
remove. */
val_end -= 3;
while (val_end > val
&& (val_end[-1] == ' ' || val_end[-1] == '\t'))
val_end--;
*val_end = '\0';
if (strcmp (var, "lexical-binding") == 0)
/* This is it... */
{
rv = (strcmp (val, "nil") != 0);
break;
}
}
}
while (ch != '\n' && ch != EOF)
ch = READCHAR;
return rv;
}
}
/* Value is a version number of byte compiled code if the file
associated with file descriptor FD is a compiled Lisp file that's
@ -1033,6 +1145,12 @@ Return t if the file exists and loads successfully. */)
Vloads_in_progress = Fcons (found, Vloads_in_progress);
}
/* All loads are by default dynamic, unless the file itself specifies
otherwise using a file-variable in the first line. This is bound here
so that it takes effect whether or not we use
Vload_source_file_function. */
specbind (Qlexical_binding, Qnil);
/* Get the name for load-history. */
hist_file_name = (! NILP (Vpurify_flag)
? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
@ -1157,15 +1275,20 @@ Return t if the file exists and loads successfully. */)
load_descriptor_list
= Fcons (make_number (fileno (stream)), load_descriptor_list);
specbind (Qload_in_progress, Qt);
instream = stream;
if (lisp_file_lexically_bound_p (Qget_file_char))
Fset (Qlexical_binding, Qt);
if (! version || version >= 22)
readevalloop (Qget_file_char, stream, hist_file_name,
Feval, 0, Qnil, Qnil, Qnil, Qnil);
0, Qnil, Qnil, Qnil, Qnil);
else
{
/* We can't handle a file which was compiled with
byte-compile-dynamic by older version of Emacs. */
specbind (Qload_force_doc_strings, Qt);
readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval,
readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name,
0, Qnil, Qnil, Qnil, Qnil);
}
unbind_to (count, Qnil);
@ -1535,7 +1658,6 @@ static void
readevalloop (Lisp_Object readcharfun,
FILE *stream,
Lisp_Object sourcename,
Lisp_Object (*evalfun) (Lisp_Object),
int printflag,
Lisp_Object unibyte, Lisp_Object readfun,
Lisp_Object start, Lisp_Object end)
@ -1546,6 +1668,7 @@ readevalloop (Lisp_Object readcharfun,
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
struct buffer *b = 0;
int continue_reading_p;
Lisp_Object lex_bound;
/* Nonzero if reading an entire buffer. */
int whole_buffer = 0;
/* 1 on the first time around. */
@ -1571,6 +1694,14 @@ readevalloop (Lisp_Object readcharfun,
record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
load_convert_to_unibyte = !NILP (unibyte);
/* If lexical binding is active (either because it was specified in
the file's header, or via a buffer-local variable), create an empty
lexical environment, otherwise, turn off lexical binding. */
lex_bound = find_symbol_value (Qlexical_binding);
specbind (Qinternal_interpreter_environment,
NILP (lex_bound) || EQ (lex_bound, Qunbound)
? Qnil : Fcons (Qt, Qnil));
GCPRO4 (sourcename, readfun, start, end);
/* Try to ensure sourcename is a truename, except whilst preloading. */
@ -1672,7 +1803,7 @@ readevalloop (Lisp_Object readcharfun,
unbind_to (count1, Qnil);
/* Now eval what we just read. */
val = (*evalfun) (val);
val = eval_sub (val);
if (printflag)
{
@ -1732,7 +1863,8 @@ This function preserves the position of point. */)
specbind (Qstandard_output, tem);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
readevalloop (buf, 0, filename, Feval,
specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
readevalloop (buf, 0, filename,
!NILP (printflag), unibyte, Qnil, Qnil, Qnil);
unbind_to (count, Qnil);
@ -1753,6 +1885,7 @@ which is the input stream for reading characters.
This function does not move point. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function)
{
/* FIXME: Do the eval-sexp-add-defvars danse! */
int count = SPECPDL_INDEX ();
Lisp_Object tem, cbuf;
@ -1766,7 +1899,7 @@ This function does not move point. */)
specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
/* readevalloop calls functions which check the type of start and end. */
readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), Feval,
readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
!NILP (printflag), Qnil, read_function,
start, end);
@ -3838,6 +3971,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd,
sym = intern_c_string (namestring);
i_fwd->type = Lisp_Fwd_Int;
i_fwd->intvar = address;
XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
}
@ -3852,6 +3986,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd,
sym = intern_c_string (namestring);
b_fwd->type = Lisp_Fwd_Bool;
b_fwd->boolvar = address;
XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
@ -3870,6 +4005,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd,
sym = intern_c_string (namestring);
o_fwd->type = Lisp_Fwd_Obj;
o_fwd->objvar = address;
XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
}
@ -3893,6 +4029,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd,
sym = intern_c_string (namestring);
ko_fwd->type = Lisp_Fwd_Kboard_Obj;
ko_fwd->offset = offset;
XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
}
@ -4320,6 +4457,15 @@ to load. See also `load-dangerous-libraries'. */);
Vbytecomp_version_regexp
= make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
Qlexical_binding = intern ("lexical-binding");
staticpro (&Qlexical_binding);
DEFVAR_LISP ("lexical-binding", Vlexical_binding,
doc: /* If non-nil, use lexical binding when evaluating code.
This only applies to code evaluated by `eval-buffer' and `eval-region'.
This variable is automatically set from the file variables of an interpreted
Lisp file read using `load'. */);
Fmake_variable_buffer_local (Qlexical_binding);
DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;

3
src/minibuf.c
View File

@ -971,7 +971,8 @@ Such arguments are used as in `read-from-minibuffer'.) */)
{
return Feval (read_minibuf (Vread_expression_map, initial_contents,
prompt, Qnil, 1, Qread_expression_history,
make_number (0), Qnil, 0, 0));
make_number (0), Qnil, 0, 0),
Qnil);
}
/* Functions that use the minibuffer to read various things. */

57
src/print.c
View File

@ -521,6 +521,7 @@ temp_output_buffer_setup (const char *bufname)
specbind (Qstandard_output, buf);
}
/* FIXME: Use Lisp's with-output-to-temp-buffer instead! */
Lisp_Object
internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args)
{
@ -542,60 +543,6 @@ internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function
return unbind_to (count, val);
}
DEFUN ("with-output-to-temp-buffer",
Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
1, UNEVALLED, 0,
doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
This construct makes buffer BUFNAME empty before running BODY.
It does not make the buffer current for BODY.
Instead it binds `standard-output' to that buffer, so that output
generated with `prin1' and similar functions in BODY goes into
the buffer.
At the end of BODY, this marks buffer BUFNAME unmodifed and displays
it in a window, but does not select it. The normal way to do this is
by calling `display-buffer', then running `temp-buffer-show-hook'.
However, if `temp-buffer-show-function' is non-nil, it calls that
function instead (and does not run `temp-buffer-show-hook'). The
function gets one argument, the buffer to display.
The return value of `with-output-to-temp-buffer' is the value of the
last form in BODY. If BODY does not finish normally, the buffer
BUFNAME is not displayed.
This runs the hook `temp-buffer-setup-hook' before BODY,
with the buffer BUFNAME temporarily current. It runs the hook
`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
buffer temporarily current, and the window that was used to display it
temporarily selected. But it doesn't run `temp-buffer-show-hook'
if it uses `temp-buffer-show-function'.
usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
(Lisp_Object args)
{
struct gcpro gcpro1;
Lisp_Object name;
int count = SPECPDL_INDEX ();
Lisp_Object buf, val;
GCPRO1(args);
name = Feval (Fcar (args));
CHECK_STRING (name);
temp_output_buffer_setup (SSDATA (name));
buf = Vstandard_output;
UNGCPRO;
val = Fprogn (XCDR (args));
GCPRO1 (val);
temp_output_buffer_show (buf);
UNGCPRO;
return unbind_to (count, val);
}
static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag);
static void print_preprocess (Lisp_Object obj);
@ -2289,6 +2236,4 @@ priorities. */);
print_prune_charset_plist = Qnil;
staticpro (&print_prune_charset_plist);
defsubr (&Swith_output_to_temp_buffer);
}

34
src/window.c
View File

@ -3705,6 +3705,16 @@ temp_output_buffer_show (register Lisp_Object buf)
}
}
}
DEFUN ("internal-temp-output-buffer-show",
Ftemp_output_buffer_show, Stemp_output_buffer_show,
1, 1, 0,
doc: /* Internal function for `with-output-to-temp-buffer''. */)
(Lisp_Object buf)
{
temp_output_buffer_show (buf);
return Qnil;
}
static void
make_dummy_parent (Lisp_Object window)
@ -6390,28 +6400,6 @@ redirection (see `redirect-frame-focus'). */)
return (tem);
}
DEFUN ("save-window-excursion", Fsave_window_excursion, Ssave_window_excursion,
0, UNEVALLED, 0,
doc: /* Execute BODY, preserving window sizes and contents.
Return the value of the last form in BODY.
Restore which buffer appears in which window, where display starts,
and the value of point and mark for each window.
Also restore the choice of selected window.
Also restore which buffer is current.
Does not restore the value of point in current buffer.
usage: (save-window-excursion BODY...) */)
(Lisp_Object args)
{
register Lisp_Object val;
register int count = SPECPDL_INDEX ();
record_unwind_protect (Fset_window_configuration,
Fcurrent_window_configuration (Qnil));
val = Fprogn (args);
return unbind_to (count, val);
}
/***********************************************************************
Window Split Tree
@ -7167,6 +7155,7 @@ frame to be redrawn only if it is a tty frame. */);
defsubr (&Sset_window_buffer);
defsubr (&Sselect_window);
defsubr (&Sforce_window_update);
defsubr (&Stemp_output_buffer_show);
defsubr (&Ssplit_window);
defsubr (&Senlarge_window);
defsubr (&Sshrink_window);
@ -7185,7 +7174,6 @@ frame to be redrawn only if it is a tty frame. */);
defsubr (&Swindow_configuration_frame);
defsubr (&Sset_window_configuration);
defsubr (&Scurrent_window_configuration);
defsubr (&Ssave_window_excursion);
defsubr (&Swindow_tree);
defsubr (&Sset_window_margins);
defsubr (&Swindow_margins);

1
src/window.h
View File

@ -853,7 +853,6 @@ EXFUN (Fwindow_minibuffer_p, 1);
EXFUN (Fdelete_window, 1);
EXFUN (Fwindow_buffer, 1);
EXFUN (Fget_buffer_window, 2);
EXFUN (Fsave_window_excursion, UNEVALLED);
EXFUN (Fset_window_configuration, 1);
EXFUN (Fcurrent_window_configuration, 1);
extern int compare_window_configurations (Lisp_Object, Lisp_Object, int);

4
test/ChangeLog
View File

@ -1,3 +1,7 @@
2011-03-10 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/lexbind-tests.el: New file.
2011-03-05 Glenn Morris <rgm@gnu.org>
* eshell.el: Move here from lisp/eshell/esh-test.el.

75
test/automated/lexbind-tests.el Normal file
View File

@ -0,0 +1,75 @@
;;; lexbind-tests.el --- Testing the lexbind byte-compiler
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(require 'ert)
(defconst lexbind-tests
`(
(let ((f #'car))
(let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
(funcall f '(1 . 2))))
)
"List of expression for test.
Each element will be executed by interpreter and with
bytecompiled code, and their results compared.")
(defun lexbind-check-1 (pat)
"Return non-nil if PAT is the same whether directly evalled or compiled."
(let ((warning-minimum-log-level :emergency)
(byte-compile-warnings nil)
(v0 (condition-case nil
(eval pat t)
(error nil)))
(v1 (condition-case nil
(funcall (let ((lexical-binding t))
(byte-compile `(lambda nil ,pat))))
(error nil))))
(equal v0 v1)))
(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1)
(defun lexbind-explain-1 (pat)
(let ((v0 (condition-case nil
(eval pat t)
(error nil)))
(v1 (condition-case nil
(funcall (let ((lexical-binding t))
(byte-compile (list 'lambda nil pat))))
(error nil))))
(format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
pat v0 v1)))
(ert-deftest lexbind-tests ()
"Test the Emacs byte compiler lexbind handling."
(dolist (pat lexbind-tests)
(should (lexbind-check-1 pat))))
(provide 'lexbind-tests)
;;; lexbind-tests.el ends here